diff options
| -rw-r--r-- | generic/tclAlloc.c | 52 | ||||
| -rw-r--r-- | generic/tclCkalloc.c | 292 | ||||
| -rw-r--r-- | generic/tclClock.c | 299 | ||||
| -rw-r--r-- | generic/tclConfig.c | 54 | ||||
| -rw-r--r-- | generic/tclDictObj.c | 1049 | ||||
| -rw-r--r-- | generic/tclEnv.c | 148 | ||||
| -rw-r--r-- | generic/tclEvent.c | 497 | ||||
| -rw-r--r-- | generic/tclFCmd.c | 157 | ||||
| -rw-r--r-- | generic/tclIOCmd.c | 415 | ||||
| -rw-r--r-- | generic/tclIOGT.c | 359 | ||||
| -rw-r--r-- | generic/tclIOUtil.c | 1749 | ||||
| -rw-r--r-- | generic/tclIndexObj.c | 105 | ||||
| -rw-r--r-- | generic/tclLiteral.c | 190 | ||||
| -rw-r--r-- | generic/tclMain.c | 89 |
14 files changed, 2761 insertions, 2694 deletions
diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c index fcdd75d..b51084d 100644 --- a/generic/tclAlloc.c +++ b/generic/tclAlloc.c @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclAlloc.c,v 1.22 2005/07/19 22:45:18 dkf Exp $ + * RCS: @(#) $Id: tclAlloc.c,v 1.23 2005/11/01 15:30:52 dkf Exp $ */ /* @@ -67,7 +67,7 @@ union overhead { unsigned long size; /* actual block size */ unsigned short unused2; /* padding to 8-byte align */ #endif - } ovu; + } ovu; #define overMagic0 ovu.magic0 #define overMagic1 ovu.magic1 #define bucketIndex ovu.index @@ -156,7 +156,7 @@ static unsigned int numMallocs[NBUCKETS+1]; * Prototypes for functions used only in this file. */ -static void MoreCore _ANSI_ARGS_((int bucket)); +static void MoreCore(int bucket); /* *------------------------------------------------------------------------- @@ -175,7 +175,7 @@ static void MoreCore _ANSI_ARGS_((int bucket)); */ void -TclInitAlloc() +TclInitAlloc(void) { if (!allocInit) { allocInit = 1; @@ -209,7 +209,7 @@ TclInitAlloc() */ void -TclFinalizeAllocSubsystem() +TclFinalizeAllocSubsystem(void) { int i; struct block *blockPtr, *nextPtr; @@ -258,8 +258,8 @@ TclFinalizeAllocSubsystem() */ char * -TclpAlloc(numBytes) - unsigned int numBytes; /* Number of bytes to allocate. */ +TclpAlloc( + unsigned int numBytes) /* Number of bytes to allocate. */ { register union overhead *overPtr; register long bucket; @@ -269,7 +269,7 @@ TclpAlloc(numBytes) if (!allocInit) { /* * We have to make the "self initializing" because Tcl_Alloc may be - * used before any other part of Tcl. E.g., see main() for tclsh! + * used before any other part of Tcl. E.g., see main() for tclsh! */ TclInitAlloc(); @@ -395,8 +395,8 @@ TclpAlloc(numBytes) */ static void -MoreCore(bucket) - int bucket; /* What bucket to allocat to. */ +MoreCore( + int bucket) /* What bucket to allocat to. */ { register union overhead *overPtr; register long size; /* size of desired block */ @@ -436,7 +436,7 @@ MoreCore(bucket) overPtr->next = (union overhead *)((caddr_t)overPtr + size); overPtr = (union overhead *)((caddr_t)overPtr + size); } - overPtr->next = (union overhead *)NULL; + overPtr->next = NULL; } /* @@ -456,8 +456,8 @@ MoreCore(bucket) */ void -TclpFree(oldPtr) - char *oldPtr; /* Pointer to memory to free. */ +TclpFree( + char *oldPtr) /* Pointer to memory to free. */ { register long size; register union overhead *overPtr; @@ -521,9 +521,9 @@ TclpFree(oldPtr) */ char * -TclpRealloc(oldPtr, numBytes) - char *oldPtr; /* Pointer to alloced block. */ - unsigned int numBytes; /* New size of memory. */ +TclpRealloc( + char *oldPtr, /* Pointer to alloced block. */ + unsigned int numBytes) /* New size of memory. */ { int i; union overhead *overPtr; @@ -653,8 +653,8 @@ TclpRealloc(oldPtr, numBytes) #ifdef MSTATS void -mstats(s) - char *s; /* Where to write info. */ +mstats( + char *s) /* Where to write info. */ { register int i, j; register union overhead *overPtr; @@ -685,7 +685,7 @@ mstats(s) } #endif -#else /* !USE_TCLALLOC */ +#else /* !USE_TCLALLOC */ /* *---------------------------------------------------------------------- @@ -704,8 +704,8 @@ mstats(s) */ char * -TclpAlloc(numBytes) - unsigned int numBytes; /* Number of bytes to allocate. */ +TclpAlloc( + unsigned int numBytes) /* Number of bytes to allocate. */ { return (char*) malloc(numBytes); } @@ -727,8 +727,8 @@ TclpAlloc(numBytes) */ void -TclpFree(oldPtr) - char *oldPtr; /* Pointer to memory to free. */ +TclpFree( + char *oldPtr) /* Pointer to memory to free. */ { free(oldPtr); return; @@ -751,9 +751,9 @@ TclpFree(oldPtr) */ char * -TclpRealloc(oldPtr, numBytes) - char *oldPtr; /* Pointer to alloced block. */ - unsigned int numBytes; /* New size of memory. */ +TclpRealloc( + char *oldPtr, /* Pointer to alloced block. */ + unsigned int numBytes) /* New size of memory. */ { return (char*) realloc(oldPtr, numBytes); } diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index e3eea4e..d04b45a 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -14,7 +14,7 @@ * * This code contributed by Karl Lehenbauer and Mark Diekhans * - * RCS: @(#) $Id: tclCkalloc.c,v 1.25 2005/09/15 16:40:02 dgp Exp $ + * RCS: @(#) $Id: tclCkalloc.c,v 1.26 2005/11/01 15:30:52 dkf Exp $ */ #include "tclInt.h" @@ -33,7 +33,7 @@ typedef struct MemTag { int refCount; /* Number of mem_headers referencing this * tag. */ char string[4]; /* Actual size of string will be as large as - * needed for actual tag. This must be the + * needed for actual tag. This must be the * last field in the structure. */ } MemTag; @@ -78,7 +78,7 @@ static struct mem_header *allocHead = NULL; /* List of allocated structures */ /* * The following macro computes the offset of the "body" field within - * mem_header. It is used to get back to the header pointer from the body + * mem_header. It is used to get back to the header pointer from the body * pointer that's used by clients. */ @@ -93,17 +93,17 @@ static int current_malloc_packets = 0; static int maximum_malloc_packets = 0; static int break_on_malloc = 0; static int trace_on_at_malloc = 0; -static int alloc_tracing = FALSE; -static int init_malloced_bodies = TRUE; +static int alloc_tracing = FALSE; +static int init_malloced_bodies = TRUE; #ifdef MEM_VALIDATE - static int validate_memory = TRUE; +static int validate_memory = TRUE; #else - static int validate_memory = FALSE; +static int validate_memory = FALSE; #endif /* * The following variable indicates to TclFinalizeMemorySubsystem() that it - * should dump out the state of memory before exiting. If the value is + * should dump out the state of memory before exiting. If the value is * non-NULL, it gives the name of the file in which to dump memory usage * information. */ @@ -115,8 +115,8 @@ static char dumpFile[100]; /* Records where to dump memory allocation * information. */ /* - * Mutex to serialize allocations. This is a low-level mutex that must be - * explicitly initialized. This is necessary because the self initializing + * Mutex to serialize allocations. This is a low-level mutex that must be + * explicitly initialized. This is necessary because the self initializing * mutexes use ckalloc... */ @@ -127,20 +127,19 @@ static int ckallocInit = 0; * Prototypes for procedures defined in this file: */ -static int CheckmemCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, CONST char *argv[])); -static int MemoryCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, CONST char **argv)); -static void ValidateMemory _ANSI_ARGS_(( - struct mem_header *memHeaderP, CONST char *file, - int line, int nukeGuards)); +static int CheckmemCmd(ClientData clientData, Tcl_Interp *interp, + int argc, CONST char *argv[]); +static int MemoryCmd(ClientData clientData, Tcl_Interp *interp, + int argc, CONST char *argv[]); +static void ValidateMemory(struct mem_header *memHeaderP, + CONST char *file, int line, int nukeGuards); /* *---------------------------------------------------------------------- * * TclInitDbCkalloc -- * - * Initialize the locks used by the allocator. This is only appropriate + * Initialize the locks used by the allocator. This is only appropriate * to call in a single threaded environment, such as during * TclInitSubsystems. * @@ -148,7 +147,7 @@ static void ValidateMemory _ANSI_ARGS_(( */ void -TclInitDbCkalloc() +TclInitDbCkalloc(void) { if (!ckallocInit) { ckallocInit = 1; @@ -167,8 +166,8 @@ TclInitDbCkalloc() */ void -TclDumpMemoryInfo(outFile) - FILE *outFile; +TclDumpMemoryInfo( + FILE *outFile) { fprintf(outFile,"total mallocs %10d\n", total_mallocs); @@ -202,15 +201,16 @@ TclDumpMemoryInfo(outFile) */ static void -ValidateMemory(memHeaderP, file, line, nukeGuards) - struct mem_header *memHeaderP; /* Memory chunk to validate */ - CONST char *file; /* File containing the call to - * Tcl_ValidateAllMemory */ - int line; /* Line number of call to - * Tcl_ValidateAllMemory */ - int nukeGuards; /* If non-zero, indicates that the - * memory guards are to be reset to 0 - * after they have been printed */ +ValidateMemory( + struct mem_header *memHeaderP, + /* Memory chunk to validate */ + CONST char *file, /* File containing the call to + * Tcl_ValidateAllMemory */ + int line, /* Line number of call to + * Tcl_ValidateAllMemory */ + int nukeGuards) /* If non-zero, indicates that the memory + * guards are to be reset to 0 after they have + * been printed */ { unsigned char *hiPtr; int idx; @@ -231,7 +231,7 @@ ValidateMemory(memHeaderP, file, line, nukeGuards) TclDumpMemoryInfo (stderr); fprintf(stderr, "low guard failed at %lx, %s %d\n", (long unsigned int) memHeaderP->body, file, line); - fflush(stderr); /* In case name pointer is bad. */ + fflush(stderr); /* In case name pointer is bad. */ fprintf(stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length, memHeaderP->file, memHeaderP->line); Tcl_Panic("Memory validation failure"); @@ -253,7 +253,7 @@ ValidateMemory(memHeaderP, file, line, nukeGuards) TclDumpMemoryInfo(stderr); fprintf(stderr, "high guard failed at %lx, %s %d\n", (long unsigned int) memHeaderP->body, file, line); - fflush(stderr); /* In case name pointer is bad. */ + fflush(stderr); /* In case name pointer is bad. */ fprintf(stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length, memHeaderP->file, memHeaderP->line); @@ -284,10 +284,10 @@ ValidateMemory(memHeaderP, file, line, nukeGuards) */ void -Tcl_ValidateAllMemory(file, line) - CONST char *file; /* File from which Tcl_ValidateAllMemory was +Tcl_ValidateAllMemory( + CONST char *file, /* File from which Tcl_ValidateAllMemory was * called. */ - int line; /* Line number of call to + int line) /* Line number of call to * Tcl_ValidateAllMemory */ { struct mem_header *memScanP; @@ -318,8 +318,8 @@ Tcl_ValidateAllMemory(file, line) */ int -Tcl_DumpActiveMemory (fileName) - CONST char *fileName; /* Name of the file to write info to */ +Tcl_DumpActiveMemory( + CONST char *fileName) /* Name of the file to write info to */ { FILE *fileP; struct mem_header *memScanP; @@ -371,10 +371,10 @@ Tcl_DumpActiveMemory (fileName) */ char * -Tcl_DbCkalloc(size, file, line) - unsigned int size; - CONST char *file; - int line; +Tcl_DbCkalloc( + unsigned int size, + CONST char *file, + int line) { struct mem_header *result; @@ -460,12 +460,12 @@ Tcl_DbCkalloc(size, file, line) return result->body; } - + char * -Tcl_AttemptDbCkalloc(size, file, line) - unsigned int size; - CONST char *file; - int line; +Tcl_AttemptDbCkalloc( + unsigned int size, + CONST char *file, + int line) { struct mem_header *result; @@ -570,10 +570,10 @@ Tcl_AttemptDbCkalloc(size, file, line) */ int -Tcl_DbCkfree(ptr, file, line) - char *ptr; - CONST char *file; - int line; +Tcl_DbCkfree( + char *ptr, + CONST char *file, + int line) { struct mem_header *memp; @@ -650,11 +650,11 @@ Tcl_DbCkfree(ptr, file, line) */ char * -Tcl_DbCkrealloc(ptr, size, file, line) - char *ptr; - unsigned int size; - CONST char *file; - int line; +Tcl_DbCkrealloc( + char *ptr, + unsigned int size, + CONST char *file, + int line) { char *new; unsigned int copySize; @@ -679,13 +679,13 @@ Tcl_DbCkrealloc(ptr, size, file, line) Tcl_DbCkfree(ptr, file, line); return new; } - + char * -Tcl_AttemptDbCkrealloc(ptr, size, file, line) - char *ptr; - unsigned int size; - CONST char *file; - int line; +Tcl_AttemptDbCkrealloc( + char *ptr, + unsigned int size, + CONST char *file, + int line) { char *new; unsigned int copySize; @@ -739,37 +739,37 @@ Tcl_AttemptDbCkrealloc(ptr, size, file, line) #undef Tcl_AttemptRealloc char * -Tcl_Alloc(size) - unsigned int size; +Tcl_Alloc( + unsigned int size) { return Tcl_DbCkalloc(size, "unknown", 0); } char * -Tcl_AttemptAlloc(size) - unsigned int size; +Tcl_AttemptAlloc( + unsigned int size) { return Tcl_AttemptDbCkalloc(size, "unknown", 0); } void -Tcl_Free(ptr) - char *ptr; +Tcl_Free( + char *ptr) { Tcl_DbCkfree(ptr, "unknown", 0); } char * -Tcl_Realloc(ptr, size) - char *ptr; - unsigned int size; +Tcl_Realloc( + char *ptr, + unsigned int size) { return Tcl_DbCkrealloc(ptr, size, "unknown", 0); } char * -Tcl_AttemptRealloc(ptr, size) - char *ptr; - unsigned int size; +Tcl_AttemptRealloc( + char *ptr, + unsigned int size) { return Tcl_AttemptDbCkrealloc(ptr, size, "unknown", 0); } @@ -798,26 +798,26 @@ Tcl_AttemptRealloc(ptr, size) */ /* ARGSUSED */ static int -MemoryCmd(clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - CONST char **argv; +MemoryCmd( + ClientData clientData, + Tcl_Interp *interp, + int argc, + CONST char *argv[]) { CONST char *fileName; Tcl_DString buffer; int result; if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " option [args..]\"", (char *) NULL); + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option [args..]\"", NULL); return TCL_ERROR; } if ((strcmp(argv[1],"active") == 0) || (strcmp(argv[1],"display") == 0)) { if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " ", argv[1], " file\"", (char *) NULL); + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ", argv[1], " file\"", NULL); return TCL_ERROR; } fileName = Tcl_TranslateFileName(interp, argv[2], &buffer); @@ -827,8 +827,7 @@ MemoryCmd(clientData, interp, argc, argv) result = Tcl_DumpActiveMemory (fileName); Tcl_DStringFree(&buffer); if (result != TCL_OK) { - Tcl_AppendResult(interp, "error accessing ", argv[2], - (char *) NULL); + Tcl_AppendResult(interp, "error accessing ", argv[2], NULL); return TCL_ERROR; } return TCL_OK; @@ -862,8 +861,8 @@ MemoryCmd(clientData, interp, argc, argv) } if (strcmp(argv[1],"onexit") == 0) { if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " onexit file\"", (char *) NULL); + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " onexit file\"", NULL); return TCL_ERROR; } fileName = Tcl_TranslateFileName(interp, argv[2], &buffer); @@ -878,7 +877,7 @@ MemoryCmd(clientData, interp, argc, argv) if (strcmp(argv[1],"tag") == 0) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " tag string\"", (char *) NULL); + " tag string\"", NULL); return TCL_ERROR; } if ((curTagPtr != NULL) && (curTagPtr->refCount == 0)) { @@ -916,17 +915,17 @@ MemoryCmd(clientData, interp, argc, argv) Tcl_AppendResult(interp, "bad option \"", argv[1], "\": should be active, break_on_malloc, info, init, onexit, ", - "tag, trace, trace_on_at_malloc, or validate", (char *) NULL); + "tag, trace, trace_on_at_malloc, or validate", NULL); return TCL_ERROR; argError: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ", argv[1], " count\"", (char *) NULL); + " ", argv[1], " count\"", NULL); return TCL_ERROR; bad_suboption: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ", argv[1], " on|off\"", (char *) NULL); + " ", argv[1], " on|off\"", NULL); return TCL_ERROR; } @@ -949,15 +948,15 @@ MemoryCmd(clientData, interp, argc, argv) */ static int -CheckmemCmd(clientData, interp, argc, argv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Interpreter for evaluation. */ - int argc; /* Number of arguments. */ - CONST char *argv[]; /* String values of arguments. */ +CheckmemCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Interpreter for evaluation. */ + int argc, /* Number of arguments. */ + CONST char *argv[]) /* String values of arguments. */ { if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " fileName\"", (char *) NULL); + " fileName\"", NULL); return TCL_ERROR; } tclMemDumpFileName = dumpFile; @@ -982,14 +981,13 @@ CheckmemCmd(clientData, interp, argc, argv) */ void -Tcl_InitMemory(interp) - Tcl_Interp *interp; /* Interpreter in which commands should be added */ +Tcl_InitMemory( + Tcl_Interp *interp) /* Interpreter in which commands should be + * added */ { TclInitDbCkalloc(); - Tcl_CreateCommand(interp, "memory", MemoryCmd, (ClientData) NULL, - (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0, - (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "memory", MemoryCmd, (ClientData) NULL, NULL); + Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0, NULL); } @@ -1014,8 +1012,8 @@ Tcl_InitMemory(interp) */ char * -Tcl_Alloc(size) - unsigned int size; +Tcl_Alloc( + unsigned int size) { char *result; @@ -1023,7 +1021,7 @@ Tcl_Alloc(size) /* * Most systems will not alloc(0), instead bumping it to one so that NULL - * isn't returned. Some systems (AIX, Tru64) will alloc(0) by returning + * isn't returned. Some systems (AIX, Tru64) will alloc(0) by returning * NULL, so we have to check that the NULL we get is not in response to * alloc(0). * @@ -1038,10 +1036,10 @@ Tcl_Alloc(size) } char * -Tcl_DbCkalloc(size, file, line) - unsigned int size; - CONST char *file; - int line; +Tcl_DbCkalloc( + unsigned int size, + CONST char *file, + int line) { char *result; @@ -1066,8 +1064,8 @@ Tcl_DbCkalloc(size, file, line) */ char * -Tcl_AttemptAlloc(size) - unsigned int size; +Tcl_AttemptAlloc( + unsigned int size) { char *result; @@ -1076,10 +1074,10 @@ Tcl_AttemptAlloc(size) } char * -Tcl_AttemptDbCkalloc(size, file, line) - unsigned int size; - CONST char *file; - int line; +Tcl_AttemptDbCkalloc( + unsigned int size, + CONST char *file, + int line) { char *result; @@ -1099,9 +1097,9 @@ Tcl_AttemptDbCkalloc(size, file, line) */ char * -Tcl_Realloc(ptr, size) - char *ptr; - unsigned int size; +Tcl_Realloc( + char *ptr, + unsigned int size) { char *result; @@ -1114,11 +1112,11 @@ Tcl_Realloc(ptr, size) } char * -Tcl_DbCkrealloc(ptr, size, file, line) - char *ptr; - unsigned int size; - CONST char *file; - int line; +Tcl_DbCkrealloc( + char *ptr, + unsigned int size, + CONST char *file, + int line) { char *result; @@ -1143,9 +1141,9 @@ Tcl_DbCkrealloc(ptr, size, file, line) */ char * -Tcl_AttemptRealloc(ptr, size) - char *ptr; - unsigned int size; +Tcl_AttemptRealloc( + char *ptr, + unsigned int size) { char *result; @@ -1154,11 +1152,11 @@ Tcl_AttemptRealloc(ptr, size) } char * -Tcl_AttemptDbCkrealloc(ptr, size, file, line) - char *ptr; - unsigned int size; - CONST char *file; - int line; +Tcl_AttemptDbCkrealloc( + char *ptr, + unsigned int size, + CONST char *file, + int line) { char *result; @@ -1179,17 +1177,17 @@ Tcl_AttemptDbCkrealloc(ptr, size, file, line) */ void -Tcl_Free(ptr) - char *ptr; +Tcl_Free( + char *ptr) { TclpFree(ptr); } int -Tcl_DbCkfree(ptr, file, line) - char *ptr; - CONST char *file; - int line; +Tcl_DbCkfree( + char *ptr, + CONST char *file, + int line) { TclpFree(ptr); return 0; @@ -1207,28 +1205,28 @@ Tcl_DbCkfree(ptr, file, line) */ /* ARGSUSED */ void -Tcl_InitMemory(interp) - Tcl_Interp *interp; +Tcl_InitMemory( + Tcl_Interp *interp) { } int -Tcl_DumpActiveMemory(fileName) - CONST char *fileName; +Tcl_DumpActiveMemory( + CONST char *fileName) { return TCL_OK; } void -Tcl_ValidateAllMemory(file, line) - CONST char *file; - int line; +Tcl_ValidateAllMemory( + CONST char *file, + int line) { } void -TclDumpMemoryInfo(outFile) - FILE *outFile; +TclDumpMemoryInfo( + FILE *outFile) { } @@ -1254,7 +1252,7 @@ TclDumpMemoryInfo(outFile) */ void -TclFinalizeMemorySubsystem() +TclFinalizeMemorySubsystem(void) { #ifdef TCL_MEM_DEBUG if (tclMemDumpFileName != NULL) { diff --git a/generic/tclClock.c b/generic/tclClock.c index c5a851e..71dec02 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -1,24 +1,24 @@ -/* +/* * tclClock.c -- * - * Contains the time and date related commands. This code - * is derived from the time and date facilities of TclX, - * by Mark Diekhans and Karl Lehenbauer. + * Contains the time and date related commands. This code is derived from + * the time and date facilities of TclX, by Mark Diekhans and Karl + * Lehenbauer. * * Copyright 1991-1995 Karl Lehenbauer and Mark Diekhans. * Copyright (c) 1995 Sun Microsystems, Inc. * Copyright (c) 2004 by Kevin B. Kenny. All rights reserved. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclClock.c,v 1.41 2005/10/19 18:39:58 dgp Exp $ + * RCS: @(#) $Id: tclClock.c,v 1.42 2005/11/01 15:30:52 dkf Exp $ */ #include "tclInt.h" /* - * Windows has mktime. The configurators do not check. + * Windows has mktime. The configurators do not check. */ #ifdef __WIN32__ @@ -26,15 +26,15 @@ #endif /* - * Thread specific data block holding a 'struct tm' for the 'gmtime' - * and 'localtime' library calls. + * Thread specific data block holding a 'struct tm' for the 'gmtime' and + * 'localtime' library calls. */ static Tcl_ThreadDataKey tmKey; /* - * Mutex protecting 'gmtime', 'localtime' and 'mktime' calls - * and the statics in the date parsing code. + * Mutex protecting 'gmtime', 'localtime' and 'mktime' calls and the statics + * in the date parsing code. */ TCL_DECLARE_MUTEX(clockMutex) @@ -43,8 +43,8 @@ TCL_DECLARE_MUTEX(clockMutex) * Function prototypes for local procedures in this file: */ -static struct tm* ThreadSafeLocalTime _ANSI_ARGS_(( CONST time_t* )); -static void TzsetIfNecessary _ANSI_ARGS_(( void )); +static struct tm * ThreadSafeLocalTime(CONST time_t *); +static void TzsetIfNecessary(void); /* *---------------------------------------------------------------------- @@ -69,26 +69,28 @@ static void TzsetIfNecessary _ANSI_ARGS_(( void )); */ int -TclClockGetenvObjCmd( ClientData clientData, - Tcl_Interp* interp, - int objc, - Tcl_Obj *CONST objv[] ) +TclClockGetenvObjCmd( + ClientData clientData, + Tcl_Interp* interp, + int objc, + Tcl_Obj *CONST objv[]) { CONST char* varName; CONST char* varValue; - if ( objc != 2 ) { - Tcl_WrongNumArgs( interp, 1, objv, "name" ); + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); return TCL_ERROR; } - varName = Tcl_GetStringFromObj( objv[1], NULL ); - varValue = getenv( varName ); - if ( varValue == NULL ) { - Tcl_SetObjResult( interp, - Tcl_NewStringObj( "variable not found", -1 ) ); + varName = Tcl_GetStringFromObj(objv[1], NULL); + varValue = getenv(varName); + if (varValue == NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("variable not found", -1)); return TCL_ERROR; } else { - Tcl_SetObjResult( interp, Tcl_NewStringObj( varValue, -1 ) ); + Tcl_SetObjResult(interp, Tcl_NewStringObj(varValue, -1)); return TCL_OK; } } @@ -108,6 +110,7 @@ TclClockGetenvObjCmd( ClientData clientData, * <tick> -- A count of seconds from the Posix epoch. * * Results: + * Returns a standard Tcl result. The object result is a Tcl * list containing the year, month, day, hour, minute, and second * fields of the local time. It may return an error if the @@ -128,14 +131,11 @@ TclClockGetenvObjCmd( ClientData clientData, */ int -TclClockLocaltimeObjCmd( ClientData clientData, - /* Unused */ - Tcl_Interp* interp, - /* Tcl interpreter */ - int objc, - /* Parameter count */ - Tcl_Obj* CONST* objv ) - /* Parameter vector */ +TclClockLocaltimeObjCmd( + ClientData clientData, /* Unused */ + Tcl_Interp* interp, /* Tcl interpreter */ + int objc, /* Parameter count */ + Tcl_Obj* CONST* objv) /* Parameter vector */ { Tcl_WideInt tick; /* Time to convert */ time_t tock; @@ -143,49 +143,50 @@ TclClockLocaltimeObjCmd( ClientData clientData, Tcl_Obj* returnVec[ 6 ]; - /* Check args */ + /* + * Check args + */ - if ( objc != 2 ) { - Tcl_WrongNumArgs( interp, 1, objv, "seconds" ); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "seconds"); return TCL_ERROR; } - if ( Tcl_GetWideIntFromObj( interp, objv[1], &tick ) != TCL_OK ) { + if (Tcl_GetWideIntFromObj(interp, objv[1], &tick) != TCL_OK) { return TCL_ERROR; } - /* Convert the time, checking for overflow */ + /* + * Convert the time, checking for overflow + */ tock = (time_t) tick; - if ( (Tcl_WideInt) tock != tick ) { - Tcl_SetObjResult - ( interp, - Tcl_NewStringObj("number too large to represent as a Posix time", - -1) ); - Tcl_SetErrorCode( interp, "CLOCK", "argTooLarge", (char*) NULL ); + if ((Tcl_WideInt) tock != tick) { + Tcl_AppendResult(interp, + "number too large to represent as a Posix time", NULL); + Tcl_SetErrorCode(interp, "CLOCK", "argTooLarge", NULL); return TCL_ERROR; } TzsetIfNecessary(); - timeVal = ThreadSafeLocalTime( &tock ); - if ( timeVal == NULL ) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("localtime failed (clock " - "value may be too large/" - "small to represent)", -1)); - Tcl_SetErrorCode(interp, "CLOCK", "localtimeFailed", (char*) NULL); + timeVal = ThreadSafeLocalTime(&tock); + if (timeVal == NULL) { + Tcl_AppendResult(interp, "localtime failed (clock value may be too ", + "large/small to represent)", NULL); + Tcl_SetErrorCode(interp, "CLOCK", "localtimeFailed", NULL); return TCL_ERROR; } - /* Package the results */ + /* + * Package the results. + */ - returnVec[0] = Tcl_NewIntObj( timeVal->tm_year + 1900 ); - returnVec[1] = Tcl_NewIntObj( timeVal->tm_mon + 1); - returnVec[2] = Tcl_NewIntObj( timeVal->tm_mday ); - returnVec[3] = Tcl_NewIntObj( timeVal->tm_hour ); - returnVec[4] = Tcl_NewIntObj( timeVal->tm_min ); - returnVec[5] = Tcl_NewIntObj( timeVal->tm_sec ); - Tcl_SetObjResult( interp, Tcl_NewListObj( 6, returnVec ) ); + returnVec[0] = Tcl_NewIntObj(timeVal->tm_year + 1900); + returnVec[1] = Tcl_NewIntObj(timeVal->tm_mon + 1); + returnVec[2] = Tcl_NewIntObj(timeVal->tm_mday); + returnVec[3] = Tcl_NewIntObj(timeVal->tm_hour); + returnVec[4] = Tcl_NewIntObj(timeVal->tm_min); + returnVec[5] = Tcl_NewIntObj(timeVal->tm_sec); + Tcl_SetObjResult(interp, Tcl_NewListObj(6, returnVec)); return TCL_OK; - } /* @@ -206,8 +207,8 @@ TclClockLocaltimeObjCmd( ClientData clientData, */ static struct tm * -ThreadSafeLocalTime(timePtr) - CONST time_t *timePtr; /* Pointer to the number of seconds since the +ThreadSafeLocalTime( + CONST time_t *timePtr) /* Pointer to the number of seconds since the * local system's epoch */ { /* @@ -239,8 +240,7 @@ ThreadSafeLocalTime(timePtr) * * TclClockMktimeObjCmd -- * - * Determine seconds from the epoch, given the fields of a local - * time. + * Determine seconds from the epoch, given the fields of a local time. * * Usage: * mktime <year> <month> <day> <hour> <minute> <second> @@ -257,8 +257,8 @@ ThreadSafeLocalTime(timePtr) * Returns the given local time. * * Errors: - * Returns an error if the 'mktime' function does not exist in the - * C library, or if the given time cannot be converted. + * Returns an error if the 'mktime' function does not exist in the C + * library, or if the given time cannot be converted. * * Side effects: * None. @@ -267,18 +267,14 @@ ThreadSafeLocalTime(timePtr) */ int -TclClockMktimeObjCmd( ClientData clientData, - /* Unused */ - Tcl_Interp* interp, - /* Tcl interpreter */ - int objc, - /* Parameter count */ - Tcl_Obj* CONST* objv ) - /* Parameter vector */ +TclClockMktimeObjCmd( + ClientData clientData, /* Unused */ + Tcl_Interp *interp, /* Tcl interpreter */ + int objc, /* Parameter count */ + Tcl_Obj *CONST *objv) /* Parameter vector */ { #ifndef HAVE_MKTIME - Tcl_SetObjResult( interp, - Tcl_NewStringObj( "cannot determine local time", -1 ) ); + Tcl_AppendResult(interp, "cannot determine local time", NULL); return TCL_ERROR; #else @@ -287,34 +283,35 @@ TclClockMktimeObjCmd( ClientData clientData, time_t convertedTime; /* Time converted from mktime */ int localErrno; - /* Convert parameters */ + /* + * Convert parameters + */ - if ( objc != 7 ) { - Tcl_WrongNumArgs( interp, 1, objv, - "year month day hour minute second" ); + if (objc != 7) { + Tcl_WrongNumArgs(interp, 1, objv, "year month day hour minute second"); return TCL_ERROR; } - if ( Tcl_GetIntFromObj( interp, objv[1], &i ) != TCL_OK ) { + if (Tcl_GetIntFromObj(interp, objv[1], &i) != TCL_OK) { return TCL_ERROR; } toConvert.tm_year = i - 1900; - if ( Tcl_GetIntFromObj( interp, objv[2], &i ) != TCL_OK ) { + if (Tcl_GetIntFromObj(interp, objv[2], &i) != TCL_OK) { return TCL_ERROR; } toConvert.tm_mon = i - 1; - if ( Tcl_GetIntFromObj( interp, objv[3], &i ) != TCL_OK ) { + if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) { return TCL_ERROR; } toConvert.tm_mday = i; - if ( Tcl_GetIntFromObj( interp, objv[4], &i ) != TCL_OK ) { + if (Tcl_GetIntFromObj(interp, objv[4], &i) != TCL_OK) { return TCL_ERROR; } toConvert.tm_hour = i; - if ( Tcl_GetIntFromObj( interp, objv[5], &i ) != TCL_OK ) { + if (Tcl_GetIntFromObj(interp, objv[5], &i) != TCL_OK) { return TCL_ERROR; } toConvert.tm_min = i; - if ( Tcl_GetIntFromObj( interp, objv[6], &i ) != TCL_OK ) { + if (Tcl_GetIntFromObj(interp, objv[6], &i) != TCL_OK) { return TCL_ERROR; } toConvert.tm_sec = i; @@ -322,34 +319,31 @@ TclClockMktimeObjCmd( ClientData clientData, toConvert.tm_wday = -1; toConvert.tm_yday = -1; - /* Convert the time. It is rumored that mktime is not thread - * safe on some platforms. */ + /* + * Convert the time. It is rumored that mktime is not thread safe on some + * platforms. + */ TzsetIfNecessary(); - Tcl_MutexLock( &clockMutex ); + Tcl_MutexLock(&clockMutex); errno = 0; - convertedTime = mktime( &toConvert ); + convertedTime = mktime(&toConvert); localErrno = errno; - Tcl_MutexUnlock( &clockMutex ); + Tcl_MutexUnlock(&clockMutex); - /* Return the converted time, or an error if conversion fails */ + /* + * Return the converted time, or an error if conversion fails. + */ - if ( localErrno != 0 - || ( convertedTime == -1 - && toConvert.tm_yday == -1 ) ) { - Tcl_SetObjResult - ( interp, - Tcl_NewStringObj( "time value too large/small to represent", - -1 ) ); + if (localErrno != 0 || (convertedTime == -1 && toConvert.tm_yday == -1)) { + Tcl_AppendResult(interp, "time value too large/small to represent", + NULL); return TCL_ERROR; - } else { - Tcl_SetObjResult( interp, - Tcl_NewWideIntObj( (Tcl_WideInt) convertedTime ) ); - return TCL_OK; } -#endif - + Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) convertedTime)); + return TCL_OK; +#endif /* HAVE_MKTIME */ } /*---------------------------------------------------------------------- @@ -364,21 +358,21 @@ TclClockMktimeObjCmd( ClientData clientData, * Side effects: * None. * - * This function implements the 'clock clicks' Tcl command. Refer - * to the user documentation for details on what it does. + * This function implements the 'clock clicks' Tcl command. Refer to the user + * documentation for details on what it does. * *---------------------------------------------------------------------- */ int -TclClockClicksObjCmd(clientData, interp, objc, objv) - ClientData clientData; /* Client data is unused */ - Tcl_Interp* interp; /* Tcl interpreter */ - int objc; /* Parameter count */ - Tcl_Obj* CONST* objv; /* Parameter values */ +TclClockClicksObjCmd( + ClientData clientData, /* Client data is unused */ + Tcl_Interp* interp, /* Tcl interpreter */ + int objc, /* Parameter count */ + Tcl_Obj* CONST* objv) /* Parameter values */ { static CONST char *clicksSwitches[] = { - "-milliseconds", "-microseconds", (char*) NULL + "-milliseconds", "-microseconds", NULL }; enum ClicksSwitch { CLICKS_MILLIS, CLICKS_MICROS, CLICKS_NATIVE @@ -432,20 +426,21 @@ TclClockClicksObjCmd(clientData, interp, objc, objv) * Side effects: * None. * - * This function implements the 'clock milliseconds' Tcl command. Refer - * to the user documentation for details on what it does. + * This function implements the 'clock milliseconds' Tcl command. Refer to the + * user documentation for details on what it does. * *---------------------------------------------------------------------- */ int -TclClockMillisecondsObjCmd(clientData, interp, objc, objv) - ClientData clientData; /* Client data is unused */ - Tcl_Interp* interp; /* Tcl interpreter */ - int objc; /* Parameter count */ - Tcl_Obj* CONST* objv; /* Parameter values */ +TclClockMillisecondsObjCmd( + ClientData clientData, /* Client data is unused */ + Tcl_Interp* interp, /* Tcl interpreter */ + int objc, /* Parameter count */ + Tcl_Obj* CONST* objv) /* Parameter values */ { Tcl_Time now; + if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; @@ -468,20 +463,21 @@ TclClockMillisecondsObjCmd(clientData, interp, objc, objv) * Side effects: * None. * - * This function implements the 'clock microseconds' Tcl command. Refer - * to the user documentation for details on what it does. + * This function implements the 'clock microseconds' Tcl command. Refer to the + * user documentation for details on what it does. * *---------------------------------------------------------------------- */ int -TclClockMicrosecondsObjCmd(clientData, interp, objc, objv) - ClientData clientData; /* Client data is unused */ - Tcl_Interp* interp; /* Tcl interpreter */ - int objc; /* Parameter count */ - Tcl_Obj* CONST* objv; /* Parameter values */ +TclClockMicrosecondsObjCmd( + ClientData clientData, /* Client data is unused */ + Tcl_Interp* interp, /* Tcl interpreter */ + int objc, /* Parameter count */ + Tcl_Obj* CONST* objv) /* Parameter values */ { Tcl_Time now; + if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; @@ -504,20 +500,21 @@ TclClockMicrosecondsObjCmd(clientData, interp, objc, objv) * Side effects: * None. * - * This function implements the 'clock seconds' Tcl command. Refer - * to the user documentation for details on what it does. + * This function implements the 'clock seconds' Tcl command. Refer to the user + * documentation for details on what it does. * *---------------------------------------------------------------------- */ int -TclClockSecondsObjCmd(clientData, interp, objc, objv) - ClientData clientData; /* Client data is unused */ - Tcl_Interp* interp; /* Tcl interpreter */ - int objc; /* Parameter count */ - Tcl_Obj* CONST* objv; /* Parameter values */ +TclClockSecondsObjCmd( + ClientData clientData, /* Client data is unused */ + Tcl_Interp* interp, /* Tcl interpreter */ + int objc, /* Parameter count */ + Tcl_Obj* CONST* objv) /* Parameter values */ { Tcl_Time now; + if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; @@ -545,27 +542,33 @@ TclClockSecondsObjCmd(clientData, interp, objc, objv) */ static void -TzsetIfNecessary() +TzsetIfNecessary(void) { static char* tzWas = NULL; /* Previous value of TZ, protected by * clockMutex. */ CONST char* tzIsNow; /* Current value of TZ */ - Tcl_MutexLock( &clockMutex ); - tzIsNow = getenv( "TZ" ); - if ( tzIsNow != NULL - && ( tzWas == NULL || strcmp( tzIsNow, tzWas ) != 0 ) ) { + Tcl_MutexLock(&clockMutex); + tzIsNow = getenv("TZ"); + if (tzIsNow != NULL && (tzWas == NULL || strcmp(tzIsNow, tzWas) != 0)) { tzset(); - if ( tzWas != NULL ) { - ckfree( tzWas ); + if (tzWas != NULL) { + ckfree(tzWas); } - tzWas = ckalloc( strlen( tzIsNow ) + 1 ); - strcpy( tzWas, tzIsNow ); - } else if ( tzIsNow == NULL && tzWas != NULL ) { + tzWas = ckalloc(strlen(tzIsNow) + 1); + strcpy(tzWas, tzIsNow); + } else if (tzIsNow == NULL && tzWas != NULL) { tzset(); - ckfree( tzWas ); + ckfree(tzWas); tzWas = NULL; } - Tcl_MutexUnlock( &clockMutex ); + Tcl_MutexUnlock(&clockMutex); } - + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclConfig.c b/generic/tclConfig.c index 49eb04b..756b396 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclConfig.c,v 1.9 2005/07/24 22:56:43 dkf Exp $ + * RCS: @(#) $Id: tclConfig.c,v 1.10 2005/11/01 15:30:52 dkf Exp $ */ #include "tclInt.h" @@ -33,13 +33,13 @@ * Static functions in this file: */ -static int QueryConfigObjCmd _ANSI_ARGS_((ClientData clientData, +static int QueryConfigObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, - struct Tcl_Obj * CONST * objv)); -static void QueryConfigDelete _ANSI_ARGS_((ClientData clientData)); -static Tcl_Obj * GetConfigDict _ANSI_ARGS_((Tcl_Interp* interp)); -static void ConfigDictDeleteProc _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp)); + struct Tcl_Obj * CONST * objv); +static void QueryConfigDelete(ClientData clientData); +static Tcl_Obj * GetConfigDict(Tcl_Interp* interp); +static void ConfigDictDeleteProc(ClientData clientData, + Tcl_Interp *interp); /* *---------------------------------------------------------------------- @@ -58,19 +58,19 @@ static void ConfigDictDeleteProc _ANSI_ARGS_(( */ void -Tcl_RegisterConfig(interp, pkgName, configuration, valEncoding) - Tcl_Interp *interp; /* Interpreter the configuration command is +Tcl_RegisterConfig( + Tcl_Interp *interp, /* Interpreter the configuration command is * registered in. */ - CONST char *pkgName; /* Name of the package registering the + CONST char *pkgName, /* Name of the package registering the * embedded configuration. ASCII, thus in * UTF-8 too. */ - Tcl_Config *configuration; /* Embedded configuration. */ - CONST char *valEncoding; /* Name of the encoding used to store the + Tcl_Config *configuration, /* Embedded configuration. */ + CONST char *valEncoding) /* Name of the encoding used to store the * configuration values, ASCII, thus UTF-8. */ { Tcl_Encoding venc = Tcl_GetEncoding(NULL, valEncoding); - Tcl_Obj *pDB = GetConfigDict(interp); - Tcl_Obj *pkg = Tcl_NewStringObj(pkgName, -1); + Tcl_Obj *pDB = GetConfigDict(interp); + Tcl_Obj *pkg = Tcl_NewStringObj(pkgName, -1); Tcl_Obj *pkgDict; Tcl_DString cmdName; Tcl_Config *cfg; @@ -180,11 +180,11 @@ Tcl_RegisterConfig(interp, pkgName, configuration, valEncoding) */ static int -QueryConfigObjCmd(clientData, interp, objc, objv) - ClientData clientData; - Tcl_Interp *interp; - int objc; - struct Tcl_Obj * CONST *objv; +QueryConfigObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + struct Tcl_Obj * CONST *objv) { Tcl_Obj *pkgName = (Tcl_Obj *) clientData; Tcl_Obj *pDB, *pkgDict, *val, *listPtr; @@ -294,8 +294,8 @@ QueryConfigObjCmd(clientData, interp, objc, objv) */ static void -QueryConfigDelete(clientData) - ClientData clientData; +QueryConfigDelete( + ClientData clientData) { Tcl_Obj *pkgName = (Tcl_Obj *) clientData; Tcl_DecrRefCount(pkgName); @@ -319,12 +319,12 @@ QueryConfigDelete(clientData) */ static Tcl_Obj * -GetConfigDict(interp) - Tcl_Interp *interp; +GetConfigDict( + Tcl_Interp *interp) { Tcl_Obj *pDB = Tcl_GetAssocData(interp, ASSOC_KEY, NULL); - if (pDB == (Tcl_Obj *) NULL) { + if (pDB == NULL) { pDB = Tcl_NewDictObj(); Tcl_IncrRefCount(pDB); Tcl_SetAssocData(interp, ASSOC_KEY, ConfigDictDeleteProc, pDB); @@ -353,9 +353,9 @@ GetConfigDict(interp) */ static void -ConfigDictDeleteProc(clientData, interp) - ClientData clientData; /* Pointer to Tcl_Obj. */ - Tcl_Interp *interp; /* Interpreter being deleted. */ +ConfigDictDeleteProc( + ClientData clientData, /* Pointer to Tcl_Obj. */ + Tcl_Interp *interp) /* Interpreter being deleted. */ { Tcl_Obj *pDB = (Tcl_Obj *) clientData; Tcl_DecrRefCount(pDB); diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 05008cb..be0a2ef 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -1,15 +1,15 @@ -/* +/* * tclDictObj.c -- * - * This file contains procedures that implement the Tcl dict object - * type and its accessor command. + * This file contains functions that implement the Tcl dict object type + * and its accessor command. * * Copyright (c) 2002 by Donal K. Fellows. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclDictObj.c,v 1.37 2005/10/19 18:39:58 dgp Exp $ + * RCS: @(#) $Id: tclDictObj.c,v 1.38 2005/11/01 15:30:52 dkf Exp $ */ #include "tclInt.h" @@ -21,82 +21,81 @@ struct Dict; /* - * Prototypes for procedures defined later in this file: + * Prototypes for functions defined later in this file: */ -static void DeleteDict _ANSI_ARGS_((struct Dict *dict)); -static int DictAppendCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static int DictCreateCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static int DictExistsCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static int DictFilterCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static int DictForCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static int DictGetCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static int DictIncrCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static int DictInfoCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static int DictKeysCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static int DictLappendCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static int DictMergeCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static int DictRemoveCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static int DictReplaceCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static int DictSetCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static int DictSizeCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static int DictUnsetCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static int DictValuesCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static int DictUpdateCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static int DictWithCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST *objv)); -static void DupDictInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, - Tcl_Obj *copyPtr)); -static void FreeDictInternalRep _ANSI_ARGS_((Tcl_Obj *dictPtr)); -static void InvalidateDictChain _ANSI_ARGS_((Tcl_Obj *dictObj)); -static int SetDictFromAny _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr)); -static void UpdateStringOfDict _ANSI_ARGS_((Tcl_Obj *dictPtr)); +static void DeleteDict(struct Dict *dict); +static int DictAppendCmd(Tcl_Interp *interp, + int objc, Tcl_Obj *CONST *objv); +static int DictCreateCmd(Tcl_Interp *interp, + int objc, Tcl_Obj *CONST *objv); +static int DictExistsCmd(Tcl_Interp *interp, + int objc, Tcl_Obj *CONST *objv); +static int DictFilterCmd(Tcl_Interp *interp, + int objc, Tcl_Obj *CONST *objv); +static int DictForCmd(Tcl_Interp *interp, + int objc, Tcl_Obj *CONST *objv); +static int DictGetCmd(Tcl_Interp *interp, + int objc, Tcl_Obj *CONST *objv); +static int DictIncrCmd(Tcl_Interp *interp, + int objc, Tcl_Obj *CONST *objv); +static int DictInfoCmd(Tcl_Interp *interp, + int objc, Tcl_Obj *CONST *objv); +static int DictKeysCmd(Tcl_Interp *interp, + int objc, Tcl_Obj *CONST *objv); +static int DictLappendCmd(Tcl_Interp *interp, + int objc, Tcl_Obj *CONST *objv); +static int DictMergeCmd(Tcl_Interp *interp, + int objc, Tcl_Obj *CONST *objv); +static int DictRemoveCmd(Tcl_Interp *interp, + int objc, Tcl_Obj *CONST *objv); +static int DictReplaceCmd(Tcl_Interp *interp, + int objc, Tcl_Obj *CONST *objv); +static int DictSetCmd(Tcl_Interp *interp, + int objc, Tcl_Obj *CONST *objv); +static int DictSizeCmd(Tcl_Interp *interp, + int objc, Tcl_Obj *CONST *objv); +static int DictUnsetCmd(Tcl_Interp *interp, + int objc, Tcl_Obj *CONST *objv); +static int DictValuesCmd(Tcl_Interp *interp, + int objc, Tcl_Obj *CONST *objv); +static int DictUpdateCmd(Tcl_Interp *interp, + int objc, Tcl_Obj *CONST *objv); +static int DictWithCmd(Tcl_Interp *interp, + int objc, Tcl_Obj *CONST *objv); +static void DupDictInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); +static void FreeDictInternalRep(Tcl_Obj *dictPtr); +static void InvalidateDictChain(Tcl_Obj *dictObj); +static int SetDictFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); +static void UpdateStringOfDict(Tcl_Obj *dictPtr); /* * Internal representation of a dictionary. * - * The internal representation of a dictionary object is a hash table - * (with Tcl_Objs for both keys and values), a reference count and - * epoch number for detecting concurrent modifications of the - * dictionary, and a pointer to the parent object (used when - * invalidating string reps of pathed dictionary trees) which is NULL - * in normal use. The fact that hash tables know (with appropriate - * initialisation) already about objects makes key management /so/ + * The internal representation of a dictionary object is a hash table (with + * Tcl_Objs for both keys and values), a reference count and epoch number for + * detecting concurrent modifications of the dictionary, and a pointer to the + * parent object (used when invalidating string reps of pathed dictionary + * trees) which is NULL in normal use. The fact that hash tables know (with + * appropriate initialisation) already about objects makes key management /so/ * much easier! * - * Reference counts are used to enable safe iteration across hashes - * while allowing the type of the containing object to be modified. + * Reference counts are used to enable safe iteration across hashes while + * allowing the type of the containing object to be modified. */ typedef struct Dict { - Tcl_HashTable table; - int epoch; - int refcount; - Tcl_Obj *chain; + Tcl_HashTable table; /* Object hash table to store mapping in. */ + int epoch; /* Epoch counter */ + int refcount; /* Reference counter (see above) */ + Tcl_Obj *chain; /* Linked list used for invalidating the + * string representations of updated nested + * dictionaries. */ } Dict; /* * The structure below defines the dictionary object type by means of - * procedures that can be invoked by generic object code. + * functions that can be invoked by generic object code. */ Tcl_ObjType tclDictType = { @@ -112,27 +111,27 @@ Tcl_ObjType tclDictType = { * * DupDictInternalRep -- * - * Initialize the internal representation of a dictionary Tcl_Obj - * to a copy of the internal representation of an existing - * dictionary object. + * Initialize the internal representation of a dictionary Tcl_Obj to a + * copy of the internal representation of an existing dictionary object. * * Results: * None. * * Side effects: - * "srcPtr"s dictionary internal rep pointer should not be NULL and - * we assume it is not NULL. We set "copyPtr"s internal rep to a - * pointer to a newly allocated dictionary rep that, in turn, points - * to "srcPtr"s key and value objects. Those objects are not - * actually copied but are shared between "srcPtr" and "copyPtr". - * The ref count of each key and value object is incremented. + * "srcPtr"s dictionary internal rep pointer should not be NULL and we + * assume it is not NULL. We set "copyPtr"s internal rep to a pointer to + * a newly allocated dictionary rep that, in turn, points to "srcPtr"s + * key and value objects. Those objects are not actually copied but are + * shared between "srcPtr" and "copyPtr". The ref count of each key and + * value object is incremented. * *---------------------------------------------------------------------- */ static void -DupDictInternalRep(srcPtr, copyPtr) - Tcl_Obj *srcPtr, *copyPtr; +DupDictInternalRep( + Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr) { Dict *oldDict = (Dict *) srcPtr->internalRep.otherValuePtr; Dict *newDict = (Dict *) ckalloc(sizeof(Dict)); @@ -164,7 +163,7 @@ DupDictInternalRep(srcPtr, copyPtr) /* * Store in the object. */ - copyPtr->internalRep.otherValuePtr = (VOID *) newDict; + copyPtr->internalRep.otherValuePtr = (void *) newDict; copyPtr->typePtr = &tclDictType; } @@ -173,23 +172,22 @@ DupDictInternalRep(srcPtr, copyPtr) * * FreeDictInternalRep -- * - * Deallocate the storage associated with a dictionary object's - * internal representation. + * Deallocate the storage associated with a dictionary object's internal + * representation. * * Results: * None * * Side effects: - * Frees the memory holding the dictionary's internal hash table - * unless it is locked by an iteration going over it. + * Frees the memory holding the dictionary's internal hash table unless + * it is locked by an iteration going over it. * *---------------------------------------------------------------------- - */ static void -FreeDictInternalRep(dictPtr) - Tcl_Obj *dictPtr; +FreeDictInternalRep( + Tcl_Obj *dictPtr) { Dict *dict = (Dict *) dictPtr->internalRep.otherValuePtr; @@ -206,34 +204,35 @@ FreeDictInternalRep(dictPtr) * * DeleteDict -- * - * Delete the structure that is used to implement a dictionary's - * internal representation. Called when either the dictionary - * object loses its internal representation or when the last - * iteration over the dictionary completes. + * Delete the structure that is used to implement a dictionary's internal + * representation. Called when either the dictionary object loses its + * internal representation or when the last iteration over the dictionary + * completes. * * Results: * None * * Side effects: - * Decrements the reference count of all key and value objects in - * the dictionary, which may free them. + * Decrements the reference count of all key and value objects in the + * dictionary, which may free them. * *---------------------------------------------------------------------- */ static void -DeleteDict(dict) - Dict *dict; +DeleteDict( + Dict *dict) { Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_Obj *valuePtr; /* - * Delete the values ourselves, because hashes know nothing about - * their contents (but do know about the key type, so that doesn't - * need explicit attention.) + * Delete the values ourselves, because hashes know nothing about their + * contents (but do know about the key type, so that doesn't need explicit + * attention.) */ + for (hPtr=Tcl_FirstHashEntry(&dict->table,&search); hPtr!=NULL; hPtr=Tcl_NextHashEntry(&search)) { valuePtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); @@ -248,26 +247,26 @@ DeleteDict(dict) * * UpdateStringOfDict -- * - * Update the string representation for a dictionary object. - * Note: This procedure does not invalidate an existing old string - * rep so storage will be lost if this has not already been done. - * This code is based on UpdateStringOfList in tclListObj.c + * Update the string representation for a dictionary object. Note: This + * function does not invalidate an existing old string rep so storage + * will be lost if this has not already been done. This code is based on + * UpdateStringOfList in tclListObj.c * * Results: * None. * * Side effects: - * The object's string is set to a valid string that results from - * the dict-to-string conversion. This string will be empty if the - * dictionary has no key/value pairs. The dictionary internal - * representation should not be NULL and we assume it is not NULL. + * The object's string is set to a valid string that results from the + * dict-to-string conversion. This string will be empty if the dictionary + * has no key/value pairs. The dictionary internal representation should + * not be NULL and we assume it is not NULL. * *---------------------------------------------------------------------- */ static void -UpdateStringOfDict(dictPtr) - Tcl_Obj *dictPtr; +UpdateStringOfDict( + Tcl_Obj *dictPtr) { #define LOCAL_SIZE 20 int localFlags[LOCAL_SIZE], *flagPtr; @@ -279,9 +278,10 @@ UpdateStringOfDict(dictPtr) char *elem, *dst; /* - * This field is the most useful one in the whole hash structure, - * and it is not exposed by any API function... + * This field is the most useful one in the whole hash structure, and it + * is not exposed by any API function... */ + numElems = dict->table.numEntries * 2; /* @@ -297,8 +297,8 @@ UpdateStringOfDict(dictPtr) for (i=0,hPtr=Tcl_FirstHashEntry(&dict->table,&search) ; i<numElems ; i+=2,hPtr=Tcl_NextHashEntry(&search)) { /* - * Assume that hPtr is never NULL since we know the number of - * array elements already. + * Assume that hPtr is never NULL since we know the number of array + * elements already. */ keyPtr = (Tcl_Obj *) Tcl_GetHashKey(&dict->table, hPtr); @@ -348,11 +348,10 @@ UpdateStringOfDict(dictPtr) * * SetDictFromAny -- * - * Convert a non-dictionary object into a dictionary object. This - * code is very closely related to SetListFromAny in tclListObj.c - * but does not actually guarantee that a dictionary object will - * have a string rep (as conversions from lists are handled with a - * special case.) + * Convert a non-dictionary object into a dictionary object. This code is + * very closely related to SetListFromAny in tclListObj.c but does not + * actually guarantee that a dictionary object will have a string rep (as + * conversions from lists are handled with a special case.) * * Results: * A standard Tcl result. @@ -365,9 +364,9 @@ UpdateStringOfDict(dictPtr) */ static int -SetDictFromAny(interp, objPtr) - Tcl_Interp *interp; - Tcl_Obj *objPtr; +SetDictFromAny( + Tcl_Interp *interp, + Tcl_Obj *objPtr) { char *string, *s; CONST char *elemStart, *nextElem; @@ -381,8 +380,8 @@ SetDictFromAny(interp, objPtr) /* * Since lists and dictionaries have very closely-related string - * representations (i.e. the same parsing code) we can safely - * special-case the conversion from lists to dictionaries. + * representations (i.e. the same parsing code) we can safely special-case + * the conversion from lists to dictionaries. */ if (objPtr->typePtr == &tclListType) { @@ -401,8 +400,8 @@ SetDictFromAny(interp, objPtr) } /* - * If the list is shared its string rep must not be lost so it - * still is the same list. + * If the list is shared its string rep must not be lost so it still + * is the same list. */ if (Tcl_IsShared(objPtr)) { @@ -431,6 +430,7 @@ SetDictFromAny(interp, objPtr) /* * Share type-setting code with the string-conversion case. */ + goto installHash; } @@ -442,8 +442,8 @@ SetDictFromAny(interp, objPtr) limit = (string + length); /* - * Allocate a new HashTable that has objects for keys and objects - * for values. + * Allocate a new HashTable that has objects for keys and objects for + * values. */ dict = (Dict *) ckalloc(sizeof(Dict)); @@ -467,14 +467,14 @@ SetDictFromAny(interp, objPtr) s = ckalloc((unsigned) elemSize + 1); if (hasBrace) { - memcpy((VOID *) s, (VOID *) elemStart, (size_t) elemSize); + memcpy((void *) s, (void *) elemStart, (size_t) elemSize); s[elemSize] = 0; } else { elemSize = TclCopyAndCollapse(elemSize, elemStart, s); } - + TclNewObj(keyPtr); - keyPtr->bytes = s; + keyPtr->bytes = s; keyPtr->length = elemSize; p = nextElem; @@ -500,19 +500,20 @@ SetDictFromAny(interp, objPtr) s = ckalloc((unsigned) elemSize + 1); if (hasBrace) { - memcpy((VOID *) s, (VOID *) elemStart, (size_t) elemSize); + memcpy((void *) s, (void *) elemStart, (size_t) elemSize); s[elemSize] = 0; } else { elemSize = TclCopyAndCollapse(elemSize, elemStart, s); } TclNewObj(valuePtr); - valuePtr->bytes = s; + valuePtr->bytes = s; valuePtr->length = elemSize; /* * Store key and value in the hash table we're building. */ + hPtr = Tcl_CreateHashEntry(&dict->table, (char *)keyPtr, &isNew); if (!isNew) { Tcl_Obj *discardedValue = (Tcl_Obj *) Tcl_GetHashValue(hPtr); @@ -525,8 +526,8 @@ SetDictFromAny(interp, objPtr) installHash: /* - * Free the old internalRep before setting the new one. We do this as - * late as possible to allow the conversion code, in particular + * Free the old internalRep before setting the new one. We do this as late + * as possible to allow the conversion code, in particular * Tcl_GetStringFromObj, to use that old internalRep. */ @@ -534,7 +535,7 @@ SetDictFromAny(interp, objPtr) dict->epoch = 0; dict->chain = NULL; dict->refcount = 1; - objPtr->internalRep.otherValuePtr = (VOID *) dict; + objPtr->internalRep.otherValuePtr = (void *) dict; objPtr->typePtr = &tclDictType; return TCL_OK; @@ -547,7 +548,7 @@ SetDictFromAny(interp, objPtr) result = TCL_ERROR; errorExit: for (hPtr=Tcl_FirstHashEntry(&dict->table,&search); - hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search)) { + hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search)) { valuePtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); TclDecrRefCount(valuePtr); } @@ -561,29 +562,27 @@ SetDictFromAny(interp, objPtr) * * TclTraceDictPath -- * - * Trace through a tree of dictionaries using the array of keys - * given. If the flags argument has the DICT_PATH_UPDATE flag is - * set, a backward-pointing chain of dictionaries is also built - * (in the Dict's chain field) and the chained dictionaries are - * made into unshared dictionaries (if they aren't already.) + * Trace through a tree of dictionaries using the array of keys given. If + * the flags argument has the DICT_PATH_UPDATE flag is set, a + * backward-pointing chain of dictionaries is also built (in the Dict's + * chain field) and the chained dictionaries are made into unshared + * dictionaries (if they aren't already.) * * Results: - * The object at the end of the path, or NULL if there was an - * error. Note that this it is an error for an intermediate - * dictionary on the path to not exist. If the flags argument - * has the DICT_PATH_EXISTS set, a non-existent path gives a - * DICT_PATH_NON_EXISTENT result. + * The object at the end of the path, or NULL if there was an error. Note + * that this it is an error for an intermediate dictionary on the path to + * not exist. If the flags argument has the DICT_PATH_EXISTS set, a + * non-existent path gives a DICT_PATH_NON_EXISTENT result. * * Side effects: - * If the flags argument is zero or DICT_PATH_EXISTS, there are - * no side effects (other than potential conversion of objects to - * dictionaries.) If the flags argument is DICT_PATH_UPDATE, the - * following additional side effects occur. Shared dictionaries - * along the path are converted into unshared objects, and a - * backward-pointing chain is built using the chain fields of the - * dictionaries (for easy invalidation of string representations - * using InvalidateDictChain.) If the flags argument has the - * DICT_PATH_CREATE bits set (and not the DICT_PATH_EXISTS bit), + * If the flags argument is zero or DICT_PATH_EXISTS, there are no side + * effects (other than potential conversion of objects to dictionaries.) + * If the flags argument is DICT_PATH_UPDATE, the following additional + * side effects occur. Shared dictionaries along the path are converted + * into unshared objects, and a backward-pointing chain is built using + * the chain fields of the dictionaries (for easy invalidation of string + * representations using InvalidateDictChain). If the flags argument has + * the DICT_PATH_CREATE bits set (and not the DICT_PATH_EXISTS bit), * non-existant keys will be inserted with a value of an empty * dictionary, resulting in the path being built. * @@ -591,10 +590,12 @@ SetDictFromAny(interp, objPtr) */ Tcl_Obj * -TclTraceDictPath(interp, dictPtr, keyc, keyv, flags) - Tcl_Interp *interp; - Tcl_Obj *dictPtr, *CONST keyv[]; - int keyc, flags; +TclTraceDictPath( + Tcl_Interp *interp, + Tcl_Obj *dictPtr, + int keyc, + Tcl_Obj *CONST keyv[], + int flags) { Dict *dict, *newDict; int i; @@ -667,24 +668,24 @@ TclTraceDictPath(interp, dictPtr, keyc, keyv, flags) * * InvalidateDictChain -- * - * Go through a dictionary chain (built by an updating invokation - * of TclTraceDictPath) and invalidate the string representations - * of all the dictionaries on the chain. + * Go through a dictionary chain (built by an updating invokation of + * TclTraceDictPath) and invalidate the string representations of all the + * dictionaries on the chain. * * Results: * None * * Side effects: - * String reps are invalidated and epoch counters (for detecting - * illegal concurrent modifications) are updated through the - * chain of updated dictionaries. + * String reps are invalidated and epoch counters (for detecting illegal + * concurrent modifications) are updated through the chain of updated + * dictionaries. * *---------------------------------------------------------------------- */ static void -InvalidateDictChain(dictObj) - Tcl_Obj *dictObj; +InvalidateDictChain( + Tcl_Obj *dictObj) { Dict *dict = (Dict *) dictObj->internalRep.otherValuePtr; @@ -705,24 +706,26 @@ InvalidateDictChain(dictObj) * * Tcl_DictObjPut -- * - * Add a key,value pair to a dictionary, or update the value for a - * key if that key already has a mapping in the dictionary. + * Add a key,value pair to a dictionary, or update the value for a key if + * that key already has a mapping in the dictionary. * * Results: * A standard Tcl result. * * Side effects: - * The object pointed to by dictPtr is converted to a dictionary if - * it is not already one, and any string representation that it has - * is invalidated. + * The object pointed to by dictPtr is converted to a dictionary if it is + * not already one, and any string representation that it has is + * invalidated. * *---------------------------------------------------------------------- */ int -Tcl_DictObjPut(interp, dictPtr, keyPtr, valuePtr) - Tcl_Interp *interp; - Tcl_Obj *dictPtr, *keyPtr, *valuePtr; +Tcl_DictObjPut( + Tcl_Interp *interp, + Tcl_Obj *dictPtr, + Tcl_Obj *keyPtr, + Tcl_Obj *valuePtr) { Dict *dict; Tcl_HashEntry *hPtr; @@ -759,25 +762,27 @@ Tcl_DictObjPut(interp, dictPtr, keyPtr, valuePtr) * * Tcl_DictObjGet -- * - * Given a key, get its value from the dictionary (or NULL if key - * is not found in dictionary.) + * Given a key, get its value from the dictionary (or NULL if key is not + * found in dictionary.) * * Results: - * A standard Tcl result. The variable pointed to by valuePtrPtr - * is updated with the value for the key. Note that it is not an - * error for the key to have no mapping in the dictionary. + * A standard Tcl result. The variable pointed to by valuePtrPtr is + * updated with the value for the key. Note that it is not an error for + * the key to have no mapping in the dictionary. * * Side effects: - * The object pointed to by dictPtr is converted to a dictionary if - * it is not already one. + * The object pointed to by dictPtr is converted to a dictionary if it is + * not already one. * *---------------------------------------------------------------------- */ int -Tcl_DictObjGet(interp, dictPtr, keyPtr, valuePtrPtr) - Tcl_Interp *interp; - Tcl_Obj *dictPtr, *keyPtr, **valuePtrPtr; +Tcl_DictObjGet( + Tcl_Interp *interp, + Tcl_Obj *dictPtr, + Tcl_Obj *keyPtr, + Tcl_Obj **valuePtrPtr) { Dict *dict; Tcl_HashEntry *hPtr; @@ -804,24 +809,25 @@ Tcl_DictObjGet(interp, dictPtr, keyPtr, valuePtrPtr) * * Tcl_DictObjRemove -- * - * Remove the key,value pair with the given key from the dictionary; - * the key does not need to be present in the dictionary. + * Remove the key,value pair with the given key from the dictionary; the + * key does not need to be present in the dictionary. * * Results: * A standard Tcl result. * * Side effects: - * The object pointed to by dictPtr is converted to a dictionary if - * it is not already one, and any string representation that it has - * is invalidated. + * The object pointed to by dictPtr is converted to a dictionary if it is + * not already one, and any string representation that it has is + * invalidated. * *---------------------------------------------------------------------- */ int -Tcl_DictObjRemove(interp, dictPtr, keyPtr) - Tcl_Interp *interp; - Tcl_Obj *dictPtr, *keyPtr; +Tcl_DictObjRemove( + Tcl_Interp *interp, + Tcl_Obj *dictPtr, + Tcl_Obj *keyPtr) { Dict *dict; Tcl_HashEntry *hPtr; @@ -860,21 +866,21 @@ Tcl_DictObjRemove(interp, dictPtr, keyPtr) * How many key,value pairs are there in the dictionary? * * Results: - * A standard Tcl result. Updates the variable pointed to by - * sizePtr with the number of key,value pairs in the dictionary. + * A standard Tcl result. Updates the variable pointed to by sizePtr with + * the number of key,value pairs in the dictionary. * * Side effects: - * The dictPtr object is converted to a dictionary type if it is - * not a dictionary already. + * The dictPtr object is converted to a dictionary type if it is not a + * dictionary already. * *---------------------------------------------------------------------- */ int -Tcl_DictObjSize(interp, dictPtr, sizePtr) - Tcl_Interp *interp; - Tcl_Obj *dictPtr; - int *sizePtr; +Tcl_DictObjSize( + Tcl_Interp *interp, + Tcl_Obj *dictPtr, + int *sizePtr) { Dict *dict; @@ -895,41 +901,39 @@ Tcl_DictObjSize(interp, dictPtr, sizePtr) * * Tcl_DictObjFirst -- * - * Start a traversal of the dictionary. Caller must supply the - * search context, pointers for returning key and value, and a - * pointer to allow indication of whether the dictionary has been - * traversed (i.e. the dictionary is empty.) The order of traversal - * is undefined. + * Start a traversal of the dictionary. Caller must supply the search + * context, pointers for returning key and value, and a pointer to allow + * indication of whether the dictionary has been traversed (i.e. the + * dictionary is empty). The order of traversal is undefined. * * Results: - * A standard Tcl result. Updates the variables pointed to by - * keyPtrPtr, valuePtrPtr and donePtr. Either of keyPtrPtr and - * valuePtrPtr may be NULL, in which case the key/value is not made - * available to the caller. + * A standard Tcl result. Updates the variables pointed to by keyPtrPtr, + * valuePtrPtr and donePtr. Either of keyPtrPtr and valuePtrPtr may be + * NULL, in which case the key/value is not made available to the caller. * * Side effects: - * The dictPtr object is converted to a dictionary type if it is - * not a dictionary already. The search context is initialised if - * the search has not finished. The dictionary's internal rep is - * Tcl_Preserve()d if the dictionary has at least one element. + * The dictPtr object is converted to a dictionary type if it is not a + * dictionary already. The search context is initialised if the search + * has not finished. The dictionary's internal rep is Tcl_Preserve()d if + * the dictionary has at least one element. * *---------------------------------------------------------------------- */ int -Tcl_DictObjFirst(interp, dictPtr, searchPtr, keyPtrPtr, valuePtrPtr, donePtr) - Tcl_Interp *interp; /* For error messages, or NULL if no - * error messages desired. */ - Tcl_Obj *dictPtr; /* Dictionary to traverse. */ - Tcl_DictSearch *searchPtr; /* Pointer to a dict search context. */ - Tcl_Obj **keyPtrPtr; /* Pointer to a variable to have the - * first key written into, or NULL. */ - Tcl_Obj **valuePtrPtr; /* Pointer to a variable to have the - * first value written into, or NULL.*/ - int *donePtr; /* Pointer to a variable which will - * have a 1 written into when there - * are no further values in the - * dictionary, or a 0 otherwise. */ +Tcl_DictObjFirst( + Tcl_Interp *interp, /* For error messages, or NULL if no error + * messages desired. */ + Tcl_Obj *dictPtr, /* Dictionary to traverse. */ + Tcl_DictSearch *searchPtr, /* Pointer to a dict search context. */ + Tcl_Obj **keyPtrPtr, /* Pointer to a variable to have the first key + * written into, or NULL. */ + Tcl_Obj **valuePtrPtr, /* Pointer to a variable to have the first + * value written into, or NULL.*/ + int *donePtr) /* Pointer to a variable which will have a 1 + * written into when there are no further + * values in the dictionary, or a 0 + * otherwise. */ { Dict *dict; Tcl_HashEntry *hPtr; @@ -967,51 +971,53 @@ Tcl_DictObjFirst(interp, dictPtr, searchPtr, keyPtrPtr, valuePtrPtr, donePtr) * Tcl_DictObjNext -- * * Continue a traversal of a dictionary previously started with - * Tcl_DictObjFirst. This function is safe against concurrent - * modification of the underlying object (including type - * shimmering), treating such situations as if the search has - * terminated, though it is up to the caller to ensure that the - * object itself is not disposed until the search has finished. - * It is _not_ safe against modifications from other threads. + * Tcl_DictObjFirst. This function is safe against concurrent + * modification of the underlying object (including type shimmering), + * treating such situations as if the search has terminated, though it is + * up to the caller to ensure that the object itself is not disposed + * until the search has finished. It is _not_ safe against modifications + * from other threads. * * Results: * Updates the variables pointed to by keyPtrPtr, valuePtrPtr and - * donePtr. Either of keyPtrPtr and valuePtrPtr may be NULL, in - * which case the key/value is not made available to the caller. + * donePtr. Either of keyPtrPtr and valuePtrPtr may be NULL, in which + * case the key/value is not made available to the caller. * * Side effects: - * Removes a reference to the dictionary's internal rep if the - * search terminates. + * Removes a reference to the dictionary's internal rep if the search + * terminates. * *---------------------------------------------------------------------- */ void -Tcl_DictObjNext(searchPtr, keyPtrPtr, valuePtrPtr, donePtr) - Tcl_DictSearch *searchPtr; /* Pointer to a hash search context. */ - Tcl_Obj **keyPtrPtr; /* Pointer to a variable to have the - * first key written into, or NULL. */ - Tcl_Obj **valuePtrPtr; /* Pointer to a variable to have the - * first value written into, or NULL.*/ - int *donePtr; /* Pointer to a variable which will - * have a 1 written into when there - * are no further values in the - * dictionary, or a 0 otherwise. */ +Tcl_DictObjNext( + Tcl_DictSearch *searchPtr, /* Pointer to a hash search context. */ + Tcl_Obj **keyPtrPtr, /* Pointer to a variable to have the first key + * written into, or NULL. */ + Tcl_Obj **valuePtrPtr, /* Pointer to a variable to have the first + * value written into, or NULL.*/ + int *donePtr) /* Pointer to a variable which will have a 1 + * written into when there are no further + * values in the dictionary, or a 0 + * otherwise. */ { Tcl_HashEntry *hPtr; /* * If the searh is done; we do no work. */ + if (searchPtr->epoch == -1) { *donePtr = 1; return; } /* - * Bail out if the dictionary has had any elements added, modified - * or removed. This *shouldn't* happen, but... + * Bail out if the dictionary has had any elements added, modified or + * removed. This *shouldn't* happen, but... */ + if (((Dict *)searchPtr->dictionaryPtr)->epoch != searchPtr->epoch) { Tcl_Panic("concurrent dictionary modification and search"); } @@ -1038,11 +1044,10 @@ Tcl_DictObjNext(searchPtr, keyPtrPtr, valuePtrPtr, donePtr) * * Tcl_DictObjDone -- * - * Call this if you want to stop a search before you reach the - * end of the dictionary (e.g. because of abnormal termination of - * the search.) It should not be used if the search reaches its - * natural end (i.e. if either Tcl_DictObjFirst or Tcl_DictObjNext - * sets its donePtr variable to 1.) + * Call this if you want to stop a search before you reach the end of the + * dictionary (e.g. because of abnormal termination of the search). It + * need not be used if the search reaches its natural end (i.e. if either + * Tcl_DictObjFirst or Tcl_DictObjNext sets its donePtr variable to 1). * * Results: * None. @@ -1054,8 +1059,8 @@ Tcl_DictObjNext(searchPtr, keyPtrPtr, valuePtrPtr, donePtr) */ void -Tcl_DictObjDone(searchPtr) - Tcl_DictSearch *searchPtr; /* Pointer to a hash search context. */ +Tcl_DictObjDone( + Tcl_DictSearch *searchPtr) /* Pointer to a hash search context. */ { Dict *dict; @@ -1074,26 +1079,28 @@ Tcl_DictObjDone(searchPtr) * * Tcl_DictObjPutKeyList -- * - * Add a key...key,value pair to a dictionary tree. The main - * dictionary value must not be shared, though sub-dictionaries may - * be. All intermediate dictionaries on the path must exist. + * Add a key...key,value pair to a dictionary tree. The main dictionary + * value must not be shared, though sub-dictionaries may be. All + * intermediate dictionaries on the path must exist. * * Results: - * A standard Tcl result. Note that in the error case, a message - * is left in interp unless that is NULL. + * A standard Tcl result. Note that in the error case, a message is left + * in interp unless that is NULL. * * Side effects: - * If the dictionary and any of its sub-dictionaries on the - * path have string representations, these are invalidated. + * If the dictionary and any of its sub-dictionaries on the path have + * string representations, these are invalidated. * *---------------------------------------------------------------------- */ int -Tcl_DictObjPutKeyList(interp, dictPtr, keyc, keyv, valuePtr) - Tcl_Interp *interp; - int keyc; - Tcl_Obj *dictPtr, *CONST keyv[], *valuePtr; +Tcl_DictObjPutKeyList( + Tcl_Interp *interp, + Tcl_Obj *dictPtr, + int keyc, + Tcl_Obj *CONST keyv[], + Tcl_Obj *valuePtr) { Dict *dict; Tcl_HashEntry *hPtr; @@ -1130,27 +1137,28 @@ Tcl_DictObjPutKeyList(interp, dictPtr, keyc, keyv, valuePtr) * Tcl_DictObjRemoveKeyList -- * * Remove a key...key,value pair from a dictionary tree (the value - * removed is implicit in the key path.) The main dictionary value - * must not be shared, though sub-dictionaries may be. It is not - * an error if there is no value associated with the given key list, - * but all intermediate dictionaries on the key path must exist. + * removed is implicit in the key path). The main dictionary value must + * not be shared, though sub-dictionaries may be. It is not an error if + * there is no value associated with the given key list, but all + * intermediate dictionaries on the key path must exist. * * Results: - * A standard Tcl result. Note that in the error case, a message - * is left in interp unless that is NULL. + * A standard Tcl result. Note that in the error case, a message is left + * in interp unless that is NULL. * * Side effects: - * If the dictionary and any of its sub-dictionaries on the key - * path have string representations, these are invalidated. + * If the dictionary and any of its sub-dictionaries on the key path have + * string representations, these are invalidated. * *---------------------------------------------------------------------- */ int -Tcl_DictObjRemoveKeyList(interp, dictPtr, keyc, keyv) - Tcl_Interp *interp; - int keyc; - Tcl_Obj *dictPtr, *CONST keyv[]; +Tcl_DictObjRemoveKeyList( + Tcl_Interp *interp, + Tcl_Obj *dictPtr, + int keyc, + Tcl_Obj *CONST keyv[]) { Dict *dict; Tcl_HashEntry *hPtr; @@ -1183,17 +1191,17 @@ Tcl_DictObjRemoveKeyList(interp, dictPtr, keyc, keyv) * * Tcl_NewDictObj -- * - * This procedure is normally called when not debugging: i.e., when - * TCL_MEM_DEBUG is not defined. It creates a new dict object - * without any content. + * This function is normally called when not debugging: i.e., when + * TCL_MEM_DEBUG is not defined. It creates a new dict object without any + * content. * - * When TCL_MEM_DEBUG is defined, this procedure just returns the - * result of calling the debugging version Tcl_DbNewDictObj. + * When TCL_MEM_DEBUG is defined, this function just returns the result + * of calling the debugging version Tcl_DbNewDictObj. * * Results: - * A new dict object is returned; it has no keys defined in it. - * The new object's string representation is left NULL, and the - * ref count of the object is 0. + * A new dict object is returned; it has no keys defined in it. The new + * object's string representation is left NULL, and the ref count of the + * object is 0. * * Side Effects: * None. @@ -1202,11 +1210,12 @@ Tcl_DictObjRemoveKeyList(interp, dictPtr, keyc, keyv) */ Tcl_Obj * -Tcl_NewDictObj() +Tcl_NewDictObj(void) { #ifdef TCL_MEM_DEBUG return Tcl_DbNewDictObj("unknown", 0); #else /* !TCL_MEM_DEBUG */ + Tcl_Obj *dictPtr; Dict *dict; @@ -1217,7 +1226,7 @@ Tcl_NewDictObj() dict->epoch = 0; dict->chain = NULL; dict->refcount = 1; - dictPtr->internalRep.otherValuePtr = (VOID *) dict; + dictPtr->internalRep.otherValuePtr = (void *) dict; dictPtr->typePtr = &tclDictType; return dictPtr; #endif @@ -1228,21 +1237,21 @@ Tcl_NewDictObj() * * Tcl_DbNewDictObj -- * - * This procedure is normally called when debugging: i.e., when - * TCL_MEM_DEBUG is defined. It creates new dict objects. It is the - * same as the Tcl_NewDictObj procedure above except that it calls + * This function is normally called when debugging: i.e., when + * TCL_MEM_DEBUG is defined. It creates new dict objects. It is the same + * as the Tcl_NewDictObj function above except that it calls * Tcl_DbCkalloc directly with the file name and line number from its * caller. This simplifies debugging since then the [memory active] - * command will report the correct file name and line number when + * command will report the correct file name and line number when * reporting objects that haven't been freed. * - * When TCL_MEM_DEBUG is not defined, this procedure just returns the + * When TCL_MEM_DEBUG is not defined, this function just returns the * result of calling Tcl_NewDictObj. * * Results: - * A new dict object is returned; it has no keys defined in it. - * The new object's string representation is left NULL, and the - * ref count of the object is 0. + * A new dict object is returned; it has no keys defined in it. The new + * object's string representation is left NULL, and the ref count of the + * object is 0. * * Side Effects: * None. @@ -1251,9 +1260,9 @@ Tcl_NewDictObj() */ Tcl_Obj * -Tcl_DbNewDictObj(file, line) - CONST char *file; - int line; +Tcl_DbNewDictObj( + CONST char *file, + int line) { #ifdef TCL_MEM_DEBUG Tcl_Obj *dictPtr; @@ -1266,7 +1275,7 @@ Tcl_DbNewDictObj(file, line) dict->epoch = 0; dict->chain = NULL; dict->refcount = 1; - dictPtr->internalRep.otherValuePtr = (VOID *) dict; + dictPtr->internalRep.otherValuePtr = (void *) dict; dictPtr->typePtr = &tclDictType; return dictPtr; #else /* !TCL_MEM_DEBUG */ @@ -1281,9 +1290,9 @@ Tcl_DbNewDictObj(file, line) * * DictCreateCmd -- * - * This function implements the "dict create" Tcl command. - * See the user documentation for details on what it does, and - * TIP#111 for the formal specification. + * This function implements the "dict create" Tcl command. See the user + * documentation for details on what it does, and TIP#111 for the formal + * specification. * * Results: * A standard Tcl result. @@ -1295,19 +1304,20 @@ Tcl_DbNewDictObj(file, line) */ static int -DictCreateCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictCreateCmd( + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST *objv) { Tcl_Obj *dictObj; int i; /* - * Must have an even number of arguments; note that number of - * preceding arguments (i.e. "dict create" is also even, which - * makes this much easier.) + * Must have an even number of arguments; note that number of preceding + * arguments (i.e. "dict create" is also even, which makes this much + * easier.) */ + if (objc & 1) { Tcl_WrongNumArgs(interp, 2, objv, "?key value ...?"); return TCL_ERROR; @@ -1329,9 +1339,9 @@ DictCreateCmd(interp, objc, objv) * * DictGetCmd -- * - * This function implements the "dict get" Tcl command. - * See the user documentation for details on what it does, and - * TIP#111 for the formal specification. + * This function implements the "dict get" Tcl command. See the user + * documentation for details on what it does, and TIP#111 for the formal + * specification. * * Results: * A standard Tcl result. @@ -1343,10 +1353,10 @@ DictCreateCmd(interp, objc, objv) */ static int -DictGetCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictGetCmd( + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST *objv) { Tcl_Obj *dictPtr, *valuePtr = NULL; int result; @@ -1357,9 +1367,9 @@ DictGetCmd(interp, objc, objv) } /* - * Test for the special case of no keys, which returns a *list* of - * all key,value pairs. We produce a copy here because that makes - * subsequent list handling more efficient. + * Test for the special case of no keys, which returns a *list* of all + * key,value pairs. We produce a copy here because that makes subsequent + * list handling more efficient. */ if (objc == 3) { @@ -1375,8 +1385,8 @@ DictGetCmd(interp, objc, objv) listPtr = Tcl_NewListObj(0, NULL); while (!done) { /* - * Assume these won't fail as we have complete control - * over the types of things here. + * Assume these won't fail as we have complete control over the + * types of things here. */ Tcl_ListObjAppendElement(interp, listPtr, keyPtr); @@ -1389,12 +1399,11 @@ DictGetCmd(interp, objc, objv) } /* - * Loop through the list of keys, looking up the key at the - * current index in the current dictionary each time. Once we've - * done the lookup, we set the current dictionary to be the value - * we looked up (in case the value was not the last one and we are - * going through a chain of searches.) Note that this loop always - * executes at least once. + * Loop through the list of keys, looking up the key at the current index + * in the current dictionary each time. Once we've done the lookup, we set + * the current dictionary to be the value we looked up (in case the value + * was not the last one and we are going through a chain of searches.) + * Note that this loop always executes at least once. */ dictPtr = TclTraceDictPath(interp, objv[2], objc-4,objv+3, DICT_PATH_READ); @@ -1420,9 +1429,9 @@ DictGetCmd(interp, objc, objv) * * DictReplaceCmd -- * - * This function implements the "dict replace" Tcl command. - * See the user documentation for details on what it does, and - * TIP#111 for the formal specification. + * This function implements the "dict replace" Tcl command. See the user + * documentation for details on what it does, and TIP#111 for the formal + * specification. * * Results: * A standard Tcl result. @@ -1434,10 +1443,10 @@ DictGetCmd(interp, objc, objv) */ static int -DictReplaceCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictReplaceCmd( + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST *objv) { Tcl_Obj *dictPtr; int i, result; @@ -1471,9 +1480,9 @@ DictReplaceCmd(interp, objc, objv) * * DictRemoveCmd -- * - * This function implements the "dict remove" Tcl command. - * See the user documentation for details on what it does, and - * TIP#111 for the formal specification. + * This function implements the "dict remove" Tcl command. See the user + * documentation for details on what it does, and TIP#111 for the formal + * specification. * * Results: * A standard Tcl result. @@ -1485,10 +1494,10 @@ DictReplaceCmd(interp, objc, objv) */ static int -DictRemoveCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictRemoveCmd( + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST *objv) { Tcl_Obj *dictPtr; int i, result; @@ -1522,9 +1531,9 @@ DictRemoveCmd(interp, objc, objv) * * DictMergeCmd -- * - * This function implements the "dict merge" Tcl command. - * See the user documentation for details on what it does, and - * TIP#163 for the formal specification. + * This function implements the "dict merge" Tcl command. See the user + * documentation for details on what it does, and TIP#163 for the formal + * specification. * * Results: * A standard Tcl result. @@ -1536,10 +1545,10 @@ DictRemoveCmd(interp, objc, objv) */ static int -DictMergeCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictMergeCmd( + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST *objv) { Tcl_Obj *targetObj, *keyObj, *valueObj; int allocatedDict = 0; @@ -1550,14 +1559,16 @@ DictMergeCmd(interp, objc, objv) /* * No dictionary arguments; return default (empty value). */ + return TCL_OK; } if (objc == 3) { /* - * Single argument, make sure it is a dictionary, but - * otherwise return it. + * Single argument, make sure it is a dictionary, but otherwise return + * it. */ + if (objv[2]->typePtr != &tclDictType) { if (SetDictFromAny(interp, objv[2]) != TCL_OK) { return TCL_ERROR; @@ -1605,9 +1616,9 @@ DictMergeCmd(interp, objc, objv) * * DictKeysCmd -- * - * This function implements the "dict keys" Tcl command. - * See the user documentation for details on what it does, and - * TIP#111 for the formal specification. + * This function implements the "dict keys" Tcl command. See the user + * documentation for details on what it does, and TIP#111 for the formal + * specification. * * Results: * A standard Tcl result. @@ -1619,10 +1630,10 @@ DictMergeCmd(interp, objc, objv) */ static int -DictKeysCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictKeysCmd( + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST *objv) { Tcl_Obj *keyPtr, *listPtr; Tcl_DictSearch search; @@ -1655,10 +1666,12 @@ DictKeysCmd(interp, objc, objv) /* * Assume this operation always succeeds. */ + Tcl_ListObjAppendElement(interp, listPtr, keyPtr); } } -searchDone: + + searchDone: Tcl_SetObjResult(interp, listPtr); return TCL_OK; } @@ -1668,9 +1681,9 @@ searchDone: * * DictValuesCmd -- * - * This function implements the "dict values" Tcl command. - * See the user documentation for details on what it does, and - * TIP#111 for the formal specification. + * This function implements the "dict values" Tcl command. See the user + * documentation for details on what it does, and TIP#111 for the formal + * specification. * * Results: * A standard Tcl result. @@ -1682,10 +1695,10 @@ searchDone: */ static int -DictValuesCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictValuesCmd( + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST *objv) { Tcl_Obj *valuePtr, *listPtr; Tcl_DictSearch search; @@ -1710,9 +1723,11 @@ DictValuesCmd(interp, objc, objv) /* * Assume this operation always succeeds. */ + Tcl_ListObjAppendElement(interp, listPtr, valuePtr); } } + Tcl_SetObjResult(interp, listPtr); return TCL_OK; } @@ -1722,9 +1737,9 @@ DictValuesCmd(interp, objc, objv) * * DictSizeCmd -- * - * This function implements the "dict size" Tcl command. - * See the user documentation for details on what it does, and - * TIP#111 for the formal specification. + * This function implements the "dict size" Tcl command. See the user + * documentation for details on what it does, and TIP#111 for the formal + * specification. * * Results: * A standard Tcl result. @@ -1736,10 +1751,10 @@ DictValuesCmd(interp, objc, objv) */ static int -DictSizeCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictSizeCmd( + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST *objv) { int result, size; @@ -1759,9 +1774,9 @@ DictSizeCmd(interp, objc, objv) * * DictExistsCmd -- * - * This function implements the "dict exists" Tcl command. - * See the user documentation for details on what it does, and - * TIP#111 for the formal specification. + * This function implements the "dict exists" Tcl command. See the user + * documentation for details on what it does, and TIP#111 for the formal + * specification. * * Results: * A standard Tcl result. @@ -1773,10 +1788,10 @@ DictSizeCmd(interp, objc, objv) */ static int -DictExistsCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictExistsCmd( + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST *objv) { Tcl_Obj *dictPtr, *valuePtr; int result; @@ -1808,9 +1823,9 @@ DictExistsCmd(interp, objc, objv) * * DictInfoCmd -- * - * This function implements the "dict info" Tcl command. - * See the user documentation for details on what it does, and - * TIP#111 for the formal specification. + * This function implements the "dict info" Tcl command. See the user + * documentation for details on what it does, and TIP#111 for the formal + * specification. * * Results: * A standard Tcl result. @@ -1822,10 +1837,10 @@ DictExistsCmd(interp, objc, objv) */ static int -DictInfoCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictInfoCmd( + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST *objv) { Tcl_Obj *dictPtr; Dict *dict; @@ -1846,6 +1861,7 @@ DictInfoCmd(interp, objc, objv) /* * This next cast is actually OK. */ + Tcl_SetResult(interp, (char *)Tcl_HashStats(&dict->table), TCL_DYNAMIC); return TCL_OK; } @@ -1855,9 +1871,9 @@ DictInfoCmd(interp, objc, objv) * * DictIncrCmd -- * - * This function implements the "dict incr" Tcl command. - * See the user documentation for details on what it does, and - * TIP#111 for the formal specification. + * This function implements the "dict incr" Tcl command. See the user + * documentation for details on what it does, and TIP#111 for the formal + * specification. * * Results: * A standard Tcl result. @@ -1869,10 +1885,10 @@ DictInfoCmd(interp, objc, objv) */ static int -DictIncrCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictIncrCmd( + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST *objv) { int code = TCL_OK; Tcl_Obj *dictPtr, *valuePtr = NULL; @@ -1884,25 +1900,42 @@ DictIncrCmd(interp, objc, objv) dictPtr = Tcl_ObjGetVar2(interp, objv[2], NULL, 0); if (dictPtr == NULL) { - /* Variable didn't yet exist. Create new dictionary value */ + /* + * Variable didn't yet exist. Create new dictionary value. + */ + dictPtr = Tcl_NewDictObj(); } else if (Tcl_DictObjGet(interp, dictPtr, objv[3], &valuePtr) != TCL_OK) { - /* Variable contents are not a dict, report error */ + /* + * Variable contents are not a dict, report error. + */ + return TCL_ERROR; } if (Tcl_IsShared(dictPtr)) { - /* A little internals surgery to avoid copying a string rep - * that will soon be no good */ + /* + * A little internals surgery to avoid copying a string rep that will + * soon be no good. + */ + char *saved = dictPtr->bytes; + dictPtr->bytes = NULL; dictPtr = Tcl_DuplicateObj(dictPtr); dictPtr->bytes = saved; } if (valuePtr == NULL) { - /* Key not in dictionary. Create new key with increment as value */ + /* + * Key not in dictionary. Create new key with increment as value. + */ + if (objc == 5) { - /* Verify increment is an integer */ + /* + * Verify increment is an integer. + */ + mp_int increment; + code = Tcl_GetBignumFromObj(interp, objv[4], &increment); if (code != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (reading increment)"); @@ -1913,7 +1946,10 @@ DictIncrCmd(interp, objc, objv) Tcl_DictObjPut(interp, dictPtr, objv[3], Tcl_NewIntObj(1)); } } else { - /* Key in dictionary. Increment its value with minimum dup. */ + /* + * Key in dictionary. Increment its value with minimum dup. + */ + if (Tcl_IsShared(valuePtr)) { valuePtr = Tcl_DuplicateObj(valuePtr); Tcl_DictObjPut(interp, dictPtr, objv[3], valuePtr); @@ -1948,9 +1984,9 @@ DictIncrCmd(interp, objc, objv) * * DictLappendCmd -- * - * This function implements the "dict lappend" Tcl command. - * See the user documentation for details on what it does, and - * TIP#111 for the formal specification. + * This function implements the "dict lappend" Tcl command. See the user + * documentation for details on what it does, and TIP#111 for the formal + * specification. * * Results: * A standard Tcl result. @@ -1962,10 +1998,10 @@ DictIncrCmd(interp, objc, objv) */ static int -DictLappendCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictLappendCmd( + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST *objv) { Tcl_Obj *dictPtr, *valuePtr, *resultPtr; int i, allocatedDict = 0, allocatedValue = 0; @@ -2036,9 +2072,9 @@ DictLappendCmd(interp, objc, objv) * * DictAppendCmd -- * - * This function implements the "dict append" Tcl command. - * See the user documentation for details on what it does, and - * TIP#111 for the formal specification. + * This function implements the "dict append" Tcl command. See the user + * documentation for details on what it does, and TIP#111 for the formal + * specification. * * Results: * A standard Tcl result. @@ -2050,10 +2086,10 @@ DictLappendCmd(interp, objc, objv) */ static int -DictAppendCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictAppendCmd( + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST *objv) { Tcl_Obj *dictPtr, *valuePtr, *resultPtr; int i, allocatedDict = 0; @@ -2109,9 +2145,9 @@ DictAppendCmd(interp, objc, objv) * * DictForCmd -- * - * This function implements the "dict for" Tcl command. - * See the user documentation for details on what it does, and - * TIP#111 for the formal specification. + * This function implements the "dict for" Tcl command. See the user + * documentation for details on what it does, and TIP#111 for the formal + * specification. * * Results: * A standard Tcl result. @@ -2123,10 +2159,10 @@ DictAppendCmd(interp, objc, objv) */ static int -DictForCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictForCmd( + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST *objv) { Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj; Tcl_Obj **varv, *keyObj, *valueObj; @@ -2150,11 +2186,13 @@ DictForCmd(interp, objc, objv) keyVarObj = varv[0]; valueVarObj = varv[1]; scriptObj = objv[4]; + /* * Make sure that these objects (which we need throughout the body of the - * loop) don't vanish. Note that the dictionary internal rep is locked + * loop) don't vanish. Note that the dictionary internal rep is locked * internally so that updates, shimmering, etc are not a problem. */ + Tcl_IncrRefCount(keyVarObj); Tcl_IncrRefCount(valueVarObj); Tcl_IncrRefCount(scriptObj); @@ -2167,14 +2205,15 @@ DictForCmd(interp, objc, objv) while (!done) { /* - * Stop the value from getting hit in any way by any traces on - * the key variable. + * Stop the value from getting hit in any way by any traces on the key + * variable. */ + Tcl_IncrRefCount(valueObj); if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, 0) == NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "couldn't set key variable: \"", - TclGetString(keyVarObj), "\"", (char *) NULL); + TclGetString(keyVarObj), "\"", NULL); TclDecrRefCount(valueObj); result = TCL_ERROR; goto doneFor; @@ -2183,7 +2222,7 @@ DictForCmd(interp, objc, objv) if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, 0) == NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "couldn't set value variable: \"", - TclGetString(valueVarObj), "\"", (char *) NULL); + TclGetString(valueVarObj), "\"", NULL); result = TCL_ERROR; goto doneFor; } @@ -2208,6 +2247,7 @@ DictForCmd(interp, objc, objv) /* * Stop holding a reference to these objects. */ + TclDecrRefCount(keyVarObj); TclDecrRefCount(valueVarObj); TclDecrRefCount(scriptObj); @@ -2224,9 +2264,9 @@ DictForCmd(interp, objc, objv) * * DictSetCmd -- * - * This function implements the "dict set" Tcl command. - * See the user documentation for details on what it does, and - * TIP#111 for the formal specification. + * This function implements the "dict set" Tcl command. See the user + * documentation for details on what it does, and TIP#111 for the formal + * specification. * * Results: * A standard Tcl result. @@ -2238,10 +2278,10 @@ DictForCmd(interp, objc, objv) */ static int -DictSetCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictSetCmd( + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST *objv) { Tcl_Obj *dictPtr, *resultPtr; int result, allocatedDict = 0; @@ -2285,9 +2325,9 @@ DictSetCmd(interp, objc, objv) * * DictUnsetCmd -- * - * This function implements the "dict unset" Tcl command. - * See the user documentation for details on what it does, and - * TIP#111 for the formal specification. + * This function implements the "dict unset" Tcl command. See the user + * documentation for details on what it does, and TIP#111 for the formal + * specification. * * Results: * A standard Tcl result. @@ -2299,10 +2339,10 @@ DictSetCmd(interp, objc, objv) */ static int -DictUnsetCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictUnsetCmd( + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST *objv) { Tcl_Obj *dictPtr, *resultPtr; int result, allocatedDict = 0; @@ -2345,9 +2385,9 @@ DictUnsetCmd(interp, objc, objv) * * DictFilterCmd -- * - * This function implements the "dict filter" Tcl command. - * See the user documentation for details on what it does, and - * TIP#111 for the formal specification. + * This function implements the "dict filter" Tcl command. See the user + * documentation for details on what it does, and TIP#111 for the formal + * specification. * * Results: * A standard Tcl result. @@ -2359,10 +2399,10 @@ DictUnsetCmd(interp, objc, objv) */ static int -DictFilterCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictFilterCmd( + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST *objv) { static CONST char *filters[] = { "key", "script", "value", NULL @@ -2395,6 +2435,7 @@ DictFilterCmd(interp, objc, objv) /* * Create a dictionary whose keys all match a certain pattern. */ + if (Tcl_DictObjFirst(interp, objv[2], &search, &keyObj, &valueObj, &done) != TCL_OK) { return TCL_ERROR; @@ -2426,6 +2467,7 @@ DictFilterCmd(interp, objc, objv) /* * Create a dictionary whose values all match a certain pattern. */ + if (Tcl_DictObjFirst(interp, objv[2], &search, &keyObj, &valueObj, &done) != TCL_OK) { return TCL_ERROR; @@ -2449,10 +2491,9 @@ DictFilterCmd(interp, objc, objv) } /* - * Create a dictionary whose key,value pairs all satisfy a - * script (i.e. get a true boolean result from its - * evaluation.) Massive copying from the "dict for" - * implementation has occurred! + * Create a dictionary whose key,value pairs all satisfy a script + * (i.e. get a true boolean result from its evaluation). Massive + * copying from the "dict for" implementation has occurred! */ if (Tcl_ListObjGetElements(interp, objv[4], &varc, &varv) != TCL_OK) { @@ -2466,12 +2507,14 @@ DictFilterCmd(interp, objc, objv) keyVarObj = varv[0]; valueVarObj = varv[1]; scriptObj = objv[5]; + /* * Make sure that these objects (which we need throughout the body of - * the loop) don't vanish. Note that the dictionary internal rep is + * the loop) don't vanish. Note that the dictionary internal rep is * locked internally so that updates, shimmering, etc are not a * problem. */ + Tcl_IncrRefCount(keyVarObj); Tcl_IncrRefCount(valueVarObj); Tcl_IncrRefCount(scriptObj); @@ -2489,16 +2532,17 @@ DictFilterCmd(interp, objc, objv) while (!done) { /* - * Stop the value from getting hit in any way by any - * traces on the key variable. + * Stop the value from getting hit in any way by any traces on the + * key variable. */ + Tcl_IncrRefCount(keyObj); Tcl_IncrRefCount(valueObj); if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "couldn't set key variable: \"", - TclGetString(keyVarObj), "\"", (char *) NULL); + TclGetString(keyVarObj), "\"", NULL); result = TCL_ERROR; goto abnormalResult; } @@ -2506,7 +2550,7 @@ DictFilterCmd(interp, objc, objv) TCL_LEAVE_ERR_MSG) == NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "couldn't set value variable: \"", - TclGetString(valueVarObj), "\"", (char *) NULL); + TclGetString(valueVarObj), "\"", NULL); goto abnormalResult; } @@ -2533,6 +2577,7 @@ DictFilterCmd(interp, objc, objv) * makes the next Tcl_DictObjNext say there is nothing more to * do. */ + Tcl_ResetResult(interp); Tcl_DictObjDone(&search); case TCL_CONTINUE: @@ -2555,6 +2600,7 @@ DictFilterCmd(interp, objc, objv) /* * Stop holding a reference to these objects. */ + TclDecrRefCount(keyVarObj); TclDecrRefCount(valueVarObj); TclDecrRefCount(scriptObj); @@ -2566,6 +2612,7 @@ DictFilterCmd(interp, objc, objv) TclDecrRefCount(resultObj); } return result; + abnormalResult: Tcl_DictObjDone(&search); TclDecrRefCount(keyObj); @@ -2586,9 +2633,9 @@ DictFilterCmd(interp, objc, objv) * * DictUpdateCmd -- * - * This function implements the "dict update" Tcl command. - * See the user documentation for details on what it does, and - * TIP#212 for the formal specification. + * This function implements the "dict update" Tcl command. See the user + * documentation for details on what it does, and TIP#212 for the formal + * specification. * * Results: * A standard Tcl result. @@ -2600,10 +2647,10 @@ DictFilterCmd(interp, objc, objv) */ static int -DictUpdateCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictUpdateCmd( + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST *objv) { Tcl_Obj *dictPtr, *objPtr; int i, result, dummy, allocdict = 0; @@ -2649,8 +2696,7 @@ DictUpdateCmd(interp, objc, objv) } /* - * If the dictionary variable doesn't exist, drop everything - * silently. + * If the dictionary variable doesn't exist, drop everything silently. */ dictPtr = Tcl_ObjGetVar2(interp, objv[2], NULL, 0); @@ -2674,8 +2720,8 @@ DictUpdateCmd(interp, objc, objv) } /* - * Write back the values from the variables, treating failure to - * read as an instruction to remove the key. + * Write back the values from the variables, treating failure to read as + * an instruction to remove the key. */ for (i=3 ; i+2<objc ; i+=2) { @@ -2709,9 +2755,9 @@ DictUpdateCmd(interp, objc, objv) * * DictWithCmd -- * - * This function implements the "dict with" Tcl command. - * See the user documentation for details on what it does, and - * TIP#212 for the formal specification. + * This function implements the "dict with" Tcl command. See the user + * documentation for details on what it does, and TIP#212 for the formal + * specification. * * Results: * A standard Tcl result. @@ -2723,10 +2769,10 @@ DictUpdateCmd(interp, objc, objv) */ static int -DictWithCmd(interp, objc, objv) - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +DictWithCmd( + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST *objv) { Tcl_Obj *dictPtr, *keysPtr, *keyPtr, *valPtr, **keyv, *leafPtr; Tcl_DictSearch s; @@ -2755,10 +2801,10 @@ DictWithCmd(interp, objc, objv) } /* - * Go over the list of keys and write each corresponding value to - * a variable in the current context with the same name. Also - * keep a copy of the keys so we can write back properly later on - * even if the dictionary has been structurally modified. + * Go over the list of keys and write each corresponding value to a + * variable in the current context with the same name. Also keep a copy of + * the keys so we can write back properly later on even if the dictionary + * has been structurally modified. */ if (Tcl_DictObjFirst(interp, dictPtr, &s, &keyPtr, &valPtr, @@ -2789,8 +2835,7 @@ DictWithCmd(interp, objc, objv) } /* - * If the dictionary variable doesn't exist, drop everything - * silently. + * If the dictionary variable doesn't exist, drop everything silently. */ dictPtr = Tcl_ObjGetVar2(interp, objv[2], NULL, 0); @@ -2817,14 +2862,14 @@ DictWithCmd(interp, objc, objv) if (objc > 4) { /* - * Want to get to the dictionary which we will update; need to - * do prepare-for-update de-sharing along the path *but* avoid - * generating an error on a non-existant path (we'll treat - * that the same as a non-existant variable. Luckily, the - * de-sharing operation isn't deeply damaging if we don't go - * on to update; it's just less than perfectly efficient (but - * no memory should be leaked). + * Want to get to the dictionary which we will update; need to do + * prepare-for-update de-sharing along the path *but* avoid generating + * an error on a non-existant path (we'll treat that the same as a + * non-existant variable. Luckily, the de-sharing operation isn't + * deeply damaging if we don't go on to update; it's just less than + * perfectly efficient (but no memory should be leaked). */ + leafPtr = TclTraceDictPath(interp, dictPtr, objc-4, objv+3, DICT_PATH_EXISTS | DICT_PATH_UPDATE); if (leafPtr == NULL) { @@ -2862,8 +2907,8 @@ DictWithCmd(interp, objc, objv) TclDecrRefCount(keysPtr); /* - * Ensure that none of the dictionaries in the chain still have a - * string rep. + * Ensure that none of the dictionaries in the chain still have a string + * rep. */ if (objc > 4) { @@ -2890,9 +2935,9 @@ DictWithCmd(interp, objc, objv) * * Tcl_DictObjCmd -- * - * This function is invoked to process the "dict" Tcl command. - * See the user documentation for details on what it does, and - * TIP#111 for the formal specification. + * This function is invoked to process the "dict" Tcl command. See the + * user documentation for details on what it does, and TIP#111 for the + * formal specification. * * Results: * A standard Tcl result. @@ -2904,11 +2949,11 @@ DictWithCmd(interp, objc, objv) */ int -Tcl_DictObjCmd(/*ignored*/ clientData, interp, objc, objv) - ClientData clientData; - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST *objv; +Tcl_DictObjCmd( + /*ignored*/ ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST *objv) { static CONST char *subcommands[] = { "append", "create", "exists", "filter", "for", @@ -2954,8 +2999,18 @@ Tcl_DictObjCmd(/*ignored*/ clientData, interp, objc, objv) case DICT_WITH: return DictWithCmd(interp, objc, objv); } Tcl_Panic("unexpected fallthrough!"); + /* * Next line is NOT REACHED - stops compliler complaint though... */ + return TCL_ERROR; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclEnv.c b/generic/tclEnv.c index 2aa927b..9417f1a 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclEnv.c,v 1.26 2005/10/05 08:03:35 hobbs Exp $ + * RCS: @(#) $Id: tclEnv.c,v 1.27 2005/11/01 15:30:52 dkf Exp $ */ #include "tclInt.h" @@ -25,21 +25,22 @@ static char **environCache = NULL; * strings that Tcl has allocated. */ #ifndef USE_PUTENV -static char **ourEnviron = NULL;/* Cache of the array that we allocate. - * We need to track this in case another +static char **ourEnviron = NULL;/* Cache of the array that we allocate. We + * need to track this in case another * subsystem swaps around the environ array * like we do. */ static int environSize = 0; /* Non-zero means that the environ array was * malloced and has this many total entries * allocated to it (not all may be in use at - * once). Zero means that the environment + * once). Zero means that the environment * array is in its original static state. */ #endif /* * For MacOS X */ + #if defined(__APPLE__) && defined(__DYNAMIC__) #include <crt_externs.h> char **environ = NULL; @@ -49,17 +50,13 @@ char **environ = NULL; * Declarations for local functions defined in this file: */ -static char * EnvTraceProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, CONST char *name1, - CONST char *name2, int flags)); -static void ReplaceString _ANSI_ARGS_((CONST char *oldStr, - char *newStr)); -void TclSetEnv _ANSI_ARGS_((CONST char *name, - CONST char *value)); -void TclUnsetEnv _ANSI_ARGS_((CONST char *name)); - -#if defined (__CYGWIN__) && defined(__WIN32__) -static void TclCygwinPutenv _ANSI_ARGS_((CONST char *string)); +static char * EnvTraceProc(ClientData clientData, Tcl_Interp *interp, + CONST char *name1, CONST char *name2, int flags); +static void ReplaceString(CONST char *oldStr, char *newStr); +void TclSetEnv(CONST char *name, CONST char *value); +void TclUnsetEnv(CONST char *name); +#if defined(__CYGWIN__) && defined(__WIN32__) +static void TclCygwinPutenv(CONST char *string); #endif /* @@ -77,7 +74,7 @@ static void TclCygwinPutenv _ANSI_ARGS_((CONST char *string)); * Side effects: * The interpreter is added to a list of interpreters managed by us, so * that its view of envariables can be kept consistent with the view in - * other interpreters. If this is the first call to TclSetupEnv, then + * other interpreters. If this is the first call to TclSetupEnv, then * additional initialization happens, such as copying the environment to * dynamically-allocated space for ease of management. * @@ -85,8 +82,8 @@ static void TclCygwinPutenv _ANSI_ARGS_((CONST char *string)); */ void -TclSetupEnv(interp) - Tcl_Interp *interp; /* Interpreter whose "env" array is to be +TclSetupEnv( + Tcl_Interp *interp) /* Interpreter whose "env" array is to be * managed. */ { Tcl_DString envString; @@ -94,15 +91,16 @@ TclSetupEnv(interp) int i; /* - * For MacOS X + * For MacOS X, need to get the real system environment. */ + #if defined(__APPLE__) && defined(__DYNAMIC__) environ = *_NSGetEnviron(); #endif /* * Synchronize the values in the environ array with the contents of the - * Tcl "env" variable. To do this: + * Tcl "env" variable. To do this: * 1) Remove the trace that fires when the "env" var is unset. * 2) Unset the "env" variable. * 3) If there are no environ variables, create an empty "env" array. @@ -110,12 +108,12 @@ TclSetupEnv(interp) * 4) Add a trace that synchronizes the "env" array. */ - Tcl_UntraceVar2(interp, "env", (char *) NULL, + Tcl_UntraceVar2(interp, "env", NULL, TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | - TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc, + TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc, (ClientData) NULL); - Tcl_UnsetVar2(interp, "env", (char *) NULL, TCL_GLOBAL_ONLY); + Tcl_UnsetVar2(interp, "env", NULL, TCL_GLOBAL_ONLY); if (environ[0] == NULL) { Tcl_Obj *varNamePtr; @@ -145,9 +143,9 @@ TclSetupEnv(interp) Tcl_MutexUnlock(&envMutex); } - Tcl_TraceVar2(interp, "env", (char *) NULL, + Tcl_TraceVar2(interp, "env", NULL, TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | - TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc, + TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc, (ClientData) NULL); } @@ -157,11 +155,11 @@ TclSetupEnv(interp) * TclSetEnv -- * * Set an environment variable, replacing an existing value or creating a - * new variable if there doesn't exist a variable by the given name. - * This function is intended to be a stand-in for the UNIX "setenv" - * function so that applications using that function will interface - * properly to Tcl. To make it a stand-in, the Makefile must define - * "TclSetEnv" to "setenv". + * new variable if there doesn't exist a variable by the given name. This + * function is intended to be a stand-in for the UNIX "setenv" function + * so that applications using that function will interface properly to + * Tcl. To make it a stand-in, the Makefile must define "TclSetEnv" to + * "setenv". * * Results: * None. @@ -173,10 +171,10 @@ TclSetupEnv(interp) */ void -TclSetEnv(name, value) - CONST char *name; /* Name of variable whose value is to be set +TclSetEnv( + CONST char *name, /* Name of variable whose value is to be set * (UTF-8). */ - CONST char *value; /* New value for variable (UTF-8). */ + CONST char *value) /* New value for variable (UTF-8). */ { Tcl_DString envString; int index, length, nameLength; @@ -196,22 +194,29 @@ TclSetEnv(name, value) #ifndef USE_PUTENV /* * We need to handle the case where the environment may be changed - * outside our control. environSize is only valid if the current + * outside our control. environSize is only valid if the current * environment is the one we allocated. [Bug 979640] */ + if ((ourEnviron != environ) || ((length + 2) > environSize)) { char **newEnviron; - newEnviron = (char **) ckalloc((unsigned) - ((length + 5) * sizeof(char *))); - memcpy((VOID *) newEnviron, (VOID *) environ, - length*sizeof(char *)); + newEnviron = (char **) + ckalloc((unsigned) ((length + 5) * sizeof(char *))); + memcpy((void *) newEnviron, (void *) environ, + length * sizeof(char *)); if ((environSize != 0) && (ourEnviron != NULL)) { ckfree((char *) ourEnviron); } environ = ourEnviron = newEnviron; environSize = length + 5; + #if defined(__APPLE__) && defined(__DYNAMIC__) + /* + * Install the new environment array where the system routines can + * see it. + */ + { char ***e = _NSGetEnviron(); *e = environ; @@ -330,8 +335,8 @@ TclSetEnv(name, value) */ int -Tcl_PutEnv(assignment) - CONST char *assignment; /* Info about environment variable in the form +Tcl_PutEnv( + CONST char *assignment) /* Info about environment variable in the form * NAME=value. (native) */ { Tcl_DString nameString; @@ -379,8 +384,8 @@ Tcl_PutEnv(assignment) */ void -TclUnsetEnv(name) - CONST char *name; /* Name of variable to remove (UTF-8). */ +TclUnsetEnv( + CONST char *name) /* Name of variable to remove (UTF-8). */ { char *oldValue; int length; @@ -404,6 +409,7 @@ TclUnsetEnv(name) Tcl_MutexUnlock(&envMutex); return; } + /* * Remember the old value so we can free it if Tcl created the string. */ @@ -411,7 +417,7 @@ TclUnsetEnv(name) oldValue = environ[index]; /* - * Update the system environment. This must be done before we update the + * Update the system environment. This must be done before we update the * interpreters or we will recurse. */ @@ -420,16 +426,17 @@ TclUnsetEnv(name) * For those platforms that support putenv to unset, Linux indicates * that no = should be included, and Windows requires it. */ + #ifdef WIN32 string = ckalloc((unsigned int) length+2); - memcpy((VOID *) string, (VOID *) name, (size_t) length); + memcpy((void *) string, (void *) name, (size_t) length); string[length] = '='; string[length+1] = '\0'; #else string = ckalloc((unsigned int) length+1); - memcpy((VOID *) string, (VOID *) name, (size_t) length); + memcpy((void *) string, (void *) name, (size_t) length); string[length] = '\0'; -#endif +#endif /* WIN32 */ Tcl_UtfToExternalDString(NULL, string, -1, &envString); string = ckrealloc(string, (unsigned) (Tcl_DStringLength(&envString)+1)); @@ -453,9 +460,9 @@ TclUnsetEnv(name) */ ckfree(string); -#endif +#endif /* HAVE_PUTENV_THAT_COPIES */ } -#else +#else /* !USE_PUTENV_FOR_UNSET */ for (envPtr = environ+index+1; ; envPtr++) { envPtr[-1] = *envPtr; if (*envPtr == NULL) { @@ -463,7 +470,7 @@ TclUnsetEnv(name) } } ReplaceString(oldValue, NULL); -#endif +#endif /* USE_PUTENV_FOR_UNSET */ Tcl_MutexUnlock(&envMutex); } @@ -489,10 +496,10 @@ TclUnsetEnv(name) */ CONST char * -TclGetEnv(name, valuePtr) - CONST char *name; /* Name of environment variable to find +TclGetEnv( + CONST char *name, /* Name of environment variable to find * (UTF-8). */ - Tcl_DString *valuePtr; /* Uninitialized or free DString in which the + Tcl_DString *valuePtr) /* Uninitialized or free DString in which the * value of the environment variable is * stored. */ { @@ -543,14 +550,14 @@ TclGetEnv(name, valuePtr) /* ARGSUSED */ static char * -EnvTraceProc(clientData, interp, name1, name2, flags) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Interpreter whose "env" variable is being +EnvTraceProc( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Interpreter whose "env" variable is being * modified. */ - CONST char *name1; /* Better be "env". */ - CONST char *name2; /* Name of variable being modified, or NULL if + CONST char *name1, /* Better be "env". */ + CONST char *name2, /* Name of variable being modified, or NULL if * whole array is being deleted (UTF-8). */ - int flags; /* Indicates what's happening. */ + int flags) /* Indicates what's happening. */ { /* * For array traces, let TclSetupEnv do all the work. @@ -611,8 +618,8 @@ EnvTraceProc(clientData, interp, name1, name2, flags) * * ReplaceString -- * - * Replace one string with another in the environment variable cache. - * The cache keeps track of all of the environment variables that Tcl has + * Replace one string with another in the environment variable cache. The + * cache keeps track of all of the environment variables that Tcl has * modified so they can be freed later. * * Results: @@ -625,9 +632,9 @@ EnvTraceProc(clientData, interp, name1, name2, flags) */ static void -ReplaceString(oldStr, newStr) - CONST char *oldStr; /* Old environment string. */ - char *newStr; /* New environment string. */ +ReplaceString( + CONST char *oldStr, /* Old environment string. */ + char *newStr) /* New environment string. */ { int i; char **newCache; @@ -669,10 +676,10 @@ ReplaceString(oldStr, newStr) */ newCache = (char **) ckalloc((unsigned) allocatedSize); - (VOID *) memset(newCache, (int) 0, (size_t) allocatedSize); + (void) memset(newCache, (int) 0, (size_t) allocatedSize); if (environCache) { - memcpy((VOID *) newCache, (VOID *) environCache, + memcpy((void *) newCache, (void *) environCache, (size_t) (cacheSize * sizeof(char*))); ckfree((char *) environCache); } @@ -702,7 +709,7 @@ ReplaceString(oldStr, newStr) */ void -TclFinalizeEnvironment() +TclFinalizeEnvironment(void) { /* * For now we just deallocate the cache array and none of the environment @@ -734,8 +741,8 @@ TclFinalizeEnvironment() */ static void -TclCygwinPutenv(str) - const char *str; +TclCygwinPutenv( + const char *str) { char *name, *value; @@ -786,7 +793,7 @@ TclCygwinPutenv(str) */ if (strcmp(name, "Path") == 0) { - SetEnvironmentVariable("PATH", (char *) NULL); + SetEnvironmentVariable("PATH", NULL); unsetenv("PATH"); } @@ -798,7 +805,7 @@ TclCygwinPutenv(str) * Eliminate any Path variable, to prevent any confusion. */ - SetEnvironmentVariable("Path", (char *) NULL); + SetEnvironmentVariable("Path", NULL); unsetenv("Path"); if (value == NULL) { @@ -814,7 +821,6 @@ TclCygwinPutenv(str) SetEnvironmentVariable(name, buf); } } - #endif /* __CYGWIN__ && __WIN32__ */ /* diff --git a/generic/tclEvent.c b/generic/tclEvent.c index cea3a15..c36d875 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1,9 +1,9 @@ -/* +/* * tclEvent.c -- * * This file implements some general event related interfaces including * background errors, exit handlers, and the "vwait" and "update" command - * procedures. + * functions. * * Copyright (c) 1990-1994 The Regents of the University of California. * Copyright (c) 1994-1998 Sun Microsystems, Inc. @@ -12,13 +12,13 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclEvent.c,v 1.64 2005/08/17 21:27:41 kennykb Exp $ + * RCS: @(#) $Id: tclEvent.c,v 1.65 2005/11/01 15:30:52 dkf Exp $ */ #include "tclInt.h" /* - * The data structure below is used to report background errors. One such + * The data structure below is used to report background errors. One such * structure is allocated for each error; it holds information about the * interpreter and the error until an idle handler command can be invoked. */ @@ -35,7 +35,7 @@ typedef struct BgError { /* * One of the structures below is associated with the "tclBgError" assoc data - * for each interpreter. It keeps track of the head and tail of the list of + * for each interpreter. It keeps track of the head and tail of the list of * pending background errors for the interpreter. */ @@ -51,20 +51,20 @@ typedef struct ErrAssocData { } ErrAssocData; /* - * For each exit handler created with a call to Tcl_CreateExitHandler - * there is a structure of the following type: + * For each exit handler created with a call to Tcl_CreateExitHandler there is + * a structure of the following type: */ typedef struct ExitHandler { - Tcl_ExitProc *proc; /* Procedure to call when process exits. */ + Tcl_ExitProc *proc; /* Function to call when process exits. */ ClientData clientData; /* One word of information to pass to proc. */ struct ExitHandler *nextPtr;/* Next in list of all exit handlers for this * application, or NULL for end of list. */ } ExitHandler; /* - * There is both per-process and per-thread exit handlers. The first list is - * controlled by a mutex. The other is in thread local storage. + * There is both per-process and per-thread exit handlers. The first list is + * controlled by a mutex. The other is in thread local storage. */ static ExitHandler *firstExitPtr = NULL; @@ -83,7 +83,7 @@ static int inFinalize = 0; static int subsystemsInitialized = 0; /* - * This variable contains the application wide exit handler. It will be + * This variable contains the application wide exit handler. It will be * called by Tcl_Exit instead of the C-runtime exit if this variable is set * to a non-NULL value. */ @@ -91,7 +91,7 @@ static int subsystemsInitialized = 0; static Tcl_ExitProc *appExitPtr = NULL; typedef struct ThreadSpecificData { - ExitHandler *firstExitPtr; /* First in list of all exit handlers for this + ExitHandler *firstExitPtr; /* First in list of all exit handlers for this * thread. */ int inExit; /* True when this thread is exiting. This is * used as a hack to decide to close the @@ -100,32 +100,29 @@ typedef struct ThreadSpecificData { static Tcl_ThreadDataKey dataKey; #ifdef TCL_THREADS - typedef struct { Tcl_ThreadCreateProc *proc; /* Main() function of the thread */ ClientData clientData; /* The one argument to Main() */ } ThreadClientData; -static Tcl_ThreadCreateType NewThreadProc _ANSI_ARGS_(( - ClientData clientData)); -#endif +static Tcl_ThreadCreateType NewThreadProc(ClientData clientData); +#endif /* TCL_THREADS */ /* - * Prototypes for procedures referenced only in this file: + * Prototypes for functions referenced only in this file: */ -static void BgErrorDeleteProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp)); -static void HandleBgErrors _ANSI_ARGS_((ClientData clientData)); -static char * VwaitVarProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, CONST char *name1, - CONST char *name2, int flags)); +static void BgErrorDeleteProc(ClientData clientData, + Tcl_Interp *interp); +static void HandleBgErrors(ClientData clientData); +static char * VwaitVarProc(ClientData clientData, Tcl_Interp *interp, + CONST char *name1, CONST char *name2, int flags); /* *---------------------------------------------------------------------- * * Tcl_BackgroundError -- * - * This procedure is invoked to handle errors that occur in Tcl commands + * This function is invoked to handle errors that occur in Tcl commands * that are invoked in "background" (e.g. from event or timer bindings). * * Results: @@ -139,8 +136,8 @@ static char * VwaitVarProc _ANSI_ARGS_((ClientData clientData, */ void -Tcl_BackgroundError(interp) - Tcl_Interp *interp; /* Interpreter in which an error has +Tcl_BackgroundError( + Tcl_Interp *interp) /* Interpreter in which an error has * occurred. */ { BgError *errPtr; @@ -154,8 +151,7 @@ Tcl_BackgroundError(interp) errPtr->nextPtr = NULL; (void) TclGetBgErrorHandler(interp); - assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp, "tclBgError", - (Tcl_InterpDeleteProc **) NULL); + assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp, "tclBgError", NULL); if (assocPtr->firstBgPtr == NULL) { assocPtr->firstBgPtr = errPtr; Tcl_DoWhenIdle(HandleBgErrors, (ClientData) assocPtr); @@ -171,7 +167,7 @@ Tcl_BackgroundError(interp) * * HandleBgErrors -- * - * This procedure is invoked as an idle handler to process all of the + * This function is invoked as an idle handler to process all of the * accumulated background errors. * * Results: @@ -184,15 +180,15 @@ Tcl_BackgroundError(interp) */ static void -HandleBgErrors(clientData) - ClientData clientData; /* Pointer to ErrAssocData structure. */ +HandleBgErrors( + ClientData clientData) /* Pointer to ErrAssocData structure. */ { ErrAssocData *assocPtr = (ErrAssocData *) clientData; Tcl_Interp *interp = assocPtr->interp; BgError *errPtr; /* - * Not bothering to save/restore the interp state. Assume that any code + * Not bothering to save/restore the interp state. Assume that any code * that has interp state it needs to keep will make its own * Tcl_SaveInterpState call before calling something like Tcl_DoOneEvent() * that could lead us here. @@ -231,6 +227,7 @@ HandleBgErrors(clientData) * Break means cancel any remaining error reports for this * interpreter. */ + while (assocPtr->firstBgPtr != NULL) { errPtr = assocPtr->firstBgPtr; assocPtr->firstBgPtr = errPtr->nextPtr; @@ -240,6 +237,7 @@ HandleBgErrors(clientData) } } else if ((code == TCL_ERROR) && !Tcl_IsSafe(interp)) { Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel != (Tcl_Channel) NULL) { Tcl_Obj *options = Tcl_GetReturnOptions(interp, code); Tcl_Obj *keyPtr = Tcl_NewStringObj("-errorinfo", -1); @@ -271,7 +269,7 @@ HandleBgErrors(clientData) * * TclDefaultBgErrorHandlerObjCmd -- * - * This procedure is invoked to process the "::tcl::Bgerror" Tcl command. + * This function is invoked to process the "::tcl::Bgerror" Tcl command. * It is the default handler command registered with [interp bgerror] for * the sake of compatibility with older Tcl releases. * @@ -285,11 +283,11 @@ HandleBgErrors(clientData) */ int -TclDefaultBgErrorHandlerObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +TclDefaultBgErrorHandlerObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { Tcl_Obj *keyPtr, *valuePtr; Tcl_Obj *tempObjv[2]; @@ -362,7 +360,7 @@ TclDefaultBgErrorHandlerObjCmd(dummy, interp, objc, objv) } } else { Tcl_WriteChars(errChannel, - "bgerror failed to handle background error.\n", -1); + "bgerror failed to handle background error.\n",-1); Tcl_WriteChars(errChannel, " Original error: ", -1); Tcl_WriteObj(errChannel, objv[1]); Tcl_WriteChars(errChannel, "\n", -1); @@ -386,7 +384,7 @@ TclDefaultBgErrorHandlerObjCmd(dummy, interp, objc, objv) * * TclSetBgErrorHandler -- * - * This procedure sets the command prefix to be used to handle background + * This function sets the command prefix to be used to handle background * errors in interp. * * Results: @@ -399,18 +397,21 @@ TclDefaultBgErrorHandlerObjCmd(dummy, interp, objc, objv) */ void -TclSetBgErrorHandler(interp, cmdPrefix) - Tcl_Interp *interp; - Tcl_Obj *cmdPrefix; +TclSetBgErrorHandler( + Tcl_Interp *interp, + Tcl_Obj *cmdPrefix) { - ErrAssocData *assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp, - "tclBgError", (Tcl_InterpDeleteProc **) NULL); + ErrAssocData *assocPtr = (ErrAssocData *) + Tcl_GetAssocData(interp, "tclBgError", NULL); if (cmdPrefix == NULL) { Tcl_Panic("TclSetBgErrorHandler: NULL cmdPrefix argument"); } if (assocPtr == NULL) { - /* First access: initialize */ + /* + * First access: initialize. + */ + assocPtr = (ErrAssocData *) ckalloc(sizeof(ErrAssocData)); assocPtr->interp = interp; assocPtr->cmdPrefix = NULL; @@ -431,7 +432,7 @@ TclSetBgErrorHandler(interp, cmdPrefix) * * TclGetBgErrorHandler -- * - * This procedure retrieves the command prefix currently used to handle + * This function retrieves the command prefix currently used to handle * background errors in interp. * * Results: @@ -444,16 +445,16 @@ TclSetBgErrorHandler(interp, cmdPrefix) */ Tcl_Obj * -TclGetBgErrorHandler(interp) - Tcl_Interp *interp; +TclGetBgErrorHandler( + Tcl_Interp *interp) { - ErrAssocData *assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp, - "tclBgError", (Tcl_InterpDeleteProc **) NULL); + ErrAssocData *assocPtr = (ErrAssocData *) + Tcl_GetAssocData(interp, "tclBgError", NULL); if (assocPtr == NULL) { TclSetBgErrorHandler(interp, Tcl_NewStringObj("::tcl::Bgerror", -1)); - assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp, - "tclBgError", (Tcl_InterpDeleteProc **) NULL); + assocPtr = (ErrAssocData *) + Tcl_GetAssocData(interp, "tclBgError", NULL); } return assocPtr->cmdPrefix; } @@ -463,7 +464,7 @@ TclGetBgErrorHandler(interp) * * BgErrorDeleteProc -- * - * This procedure is associated with the "tclBgError" assoc data for an + * This function is associated with the "tclBgError" assoc data for an * interpreter; it is invoked when the interpreter is deleted in order to * free the information assoicated with any pending error reports. * @@ -478,9 +479,9 @@ TclGetBgErrorHandler(interp) */ static void -BgErrorDeleteProc(clientData, interp) - ClientData clientData; /* Pointer to ErrAssocData structure. */ - Tcl_Interp *interp; /* Interpreter being deleted. */ +BgErrorDeleteProc( + ClientData clientData, /* Pointer to ErrAssocData structure. */ + Tcl_Interp *interp) /* Interpreter being deleted. */ { ErrAssocData *assocPtr = (ErrAssocData *) clientData; BgError *errPtr; @@ -502,8 +503,8 @@ BgErrorDeleteProc(clientData, interp) * * Tcl_CreateExitHandler -- * - * Arrange for a given procedure to be invoked just before the - * application exits. + * Arrange for a given function to be invoked just before the application + * exits. * * Results: * None. @@ -516,9 +517,9 @@ BgErrorDeleteProc(clientData, interp) */ void -Tcl_CreateExitHandler(proc, clientData) - Tcl_ExitProc *proc; /* Procedure to invoke. */ - ClientData clientData; /* Arbitrary value to pass to proc. */ +Tcl_CreateExitHandler( + Tcl_ExitProc *proc, /* Function to invoke. */ + ClientData clientData) /* Arbitrary value to pass to proc. */ { ExitHandler *exitPtr; @@ -536,7 +537,7 @@ Tcl_CreateExitHandler(proc, clientData) * * Tcl_DeleteExitHandler -- * - * This procedure cancels an existing exit handler matching proc and + * This function cancels an existing exit handler matching proc and * clientData, if such a handler exits. * * Results: @@ -550,9 +551,9 @@ Tcl_CreateExitHandler(proc, clientData) */ void -Tcl_DeleteExitHandler(proc, clientData) - Tcl_ExitProc *proc; /* Procedure that was previously registered. */ - ClientData clientData; /* Arbitrary value to pass to proc. */ +Tcl_DeleteExitHandler( + Tcl_ExitProc *proc, /* Function that was previously registered. */ + ClientData clientData) /* Arbitrary value to pass to proc. */ { ExitHandler *exitPtr, *prevPtr; @@ -579,7 +580,7 @@ Tcl_DeleteExitHandler(proc, clientData) * * Tcl_CreateThreadExitHandler -- * - * Arrange for a given procedure to be invoked just before the current + * Arrange for a given function to be invoked just before the current * thread exits. * * Results: @@ -593,9 +594,9 @@ Tcl_DeleteExitHandler(proc, clientData) */ void -Tcl_CreateThreadExitHandler(proc, clientData) - Tcl_ExitProc *proc; /* Procedure to invoke. */ - ClientData clientData; /* Arbitrary value to pass to proc. */ +Tcl_CreateThreadExitHandler( + Tcl_ExitProc *proc, /* Function to invoke. */ + ClientData clientData) /* Arbitrary value to pass to proc. */ { ExitHandler *exitPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -612,7 +613,7 @@ Tcl_CreateThreadExitHandler(proc, clientData) * * Tcl_DeleteThreadExitHandler -- * - * This procedure cancels an existing exit handler matching proc and + * This function cancels an existing exit handler matching proc and * clientData, if such a handler exits. * * Results: @@ -626,9 +627,9 @@ Tcl_CreateThreadExitHandler(proc, clientData) */ void -Tcl_DeleteThreadExitHandler(proc, clientData) - Tcl_ExitProc *proc; /* Procedure that was previously registered. */ - ClientData clientData; /* Arbitrary value to pass to proc. */ +Tcl_DeleteThreadExitHandler( + Tcl_ExitProc *proc, /* Function that was previously registered. */ + ClientData clientData) /* Arbitrary value to pass to proc. */ { ExitHandler *exitPtr, *prevPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -653,8 +654,8 @@ Tcl_DeleteThreadExitHandler(proc, clientData) * * Tcl_SetExitProc -- * - * This procedure sets the application wide exit handler that will be - * called by Tcl_Exit in place of the C-runtime exit. If the application + * This function sets the application wide exit handler that will be + * called by Tcl_Exit in place of the C-runtime exit. If the application * wide exit handler is NULL, the C-runtime exit will be used instead. * * Results: @@ -667,8 +668,8 @@ Tcl_DeleteThreadExitHandler(proc, clientData) */ Tcl_ExitProc * -Tcl_SetExitProc(proc) - Tcl_ExitProc *proc; /* new exit handler for app or NULL */ +Tcl_SetExitProc( + Tcl_ExitProc *proc) /* New exit handler for app or NULL */ { Tcl_ExitProc *prevExitProc; @@ -690,7 +691,7 @@ Tcl_SetExitProc(proc) * * Tcl_Exit -- * - * This procedure is called to terminate the application. + * This function is called to terminate the application. * * Results: * None. @@ -702,9 +703,9 @@ Tcl_SetExitProc(proc) */ void -Tcl_Exit(status) - int status; /* Exit status for application; typically - * 0 for normal return, 1 for error return. */ +Tcl_Exit( + int status) /* Exit status for application; typically 0 + * for normal return, 1 for error return. */ { Tcl_ExitProc *currentAppExitPtr; @@ -715,14 +716,17 @@ Tcl_Exit(status) if (currentAppExitPtr) { /* * Warning: this code SHOULD NOT return, as there is code that depends - * on Tcl_Exit never returning. In fact, we will Tcl_Panic if anyone + * on Tcl_Exit never returning. In fact, we will Tcl_Panic if anyone * returns, so critical is this dependcy. */ currentAppExitPtr((ClientData) status); Tcl_Panic("AppExitProc returned unexpectedly"); } else { - /* use default handling */ + /* + * Use default handling. + */ + Tcl_Finalize(); TclpExit(status); Tcl_Panic("OS exit failed!"); @@ -734,7 +738,7 @@ Tcl_Exit(status) * * TclInitSubsystems -- * - * Initialize various subsytems in Tcl. This should be called the first + * Initialize various subsytems in Tcl. This should be called the first * time an interp is created, or before any of the subsystems are used. * This function ensures an order for the initialization of subsystems: * @@ -755,16 +759,16 @@ Tcl_Exit(status) */ void -TclInitSubsystems() +TclInitSubsystems(void) { if (inFinalize != 0) { Tcl_Panic("TclInitSubsystems called while finalizing"); } if (subsystemsInitialized == 0) { - /* - * Double check inside the mutex. There are definitly calls back into - * this routine from some of the procedures below. + /* + * Double check inside the mutex. There are definitly calls back into + * this routine from some of the functions below. */ TclpInitLock(); @@ -811,8 +815,8 @@ TclInitSubsystems() * * Tcl_Finalize -- * - * Shut down Tcl. First calls registered exit handlers, then carefully - * shuts down various subsystems. Called by Tcl_Exit or when the Tcl + * Shut down Tcl. First calls registered exit handlers, then carefully + * shuts down various subsystems. Called by Tcl_Exit or when the Tcl * shared library is being unloaded. * * Results: @@ -825,10 +829,10 @@ TclInitSubsystems() */ void -Tcl_Finalize() +Tcl_Finalize(void) { ExitHandler *exitPtr; - + /* * Invoke exit handlers first. */ @@ -838,7 +842,7 @@ Tcl_Finalize() for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) { /* * Be careful to remove the handler from the list before invoking its - * callback. This protects us against double-freeing if the callback + * callback. This protects us against double-freeing if the callback * should call Tcl_DeleteExitHandler on itself. */ @@ -847,138 +851,146 @@ Tcl_Finalize() (*exitPtr->proc)(exitPtr->clientData); ckfree((char *) exitPtr); Tcl_MutexLock(&exitMutex); - } + } firstExitPtr = NULL; Tcl_MutexUnlock(&exitMutex); TclpInitLock(); - if (subsystemsInitialized != 0) { - subsystemsInitialized = 0; + if (subsystemsInitialized == 0) { + goto alreadyFinalized; + } + subsystemsInitialized = 0; - /* - * Ensure the thread-specific data is initialised as it is used in - * Tcl_FinalizeThread() - */ + /* + * Ensure the thread-specific data is initialised as it is used in + * Tcl_FinalizeThread() + */ - (void) TCL_TSD_INIT(&dataKey); + (void) TCL_TSD_INIT(&dataKey); - /* - * Clean up after the current thread now, after exit handlers. In - * particular, the testexithandler command sets up something that - * writes to standard output, which gets closed. Note that there is - * no thread-local storage after this call. - */ + /* + * Clean up after the current thread now, after exit handlers. In + * particular, the testexithandler command sets up something that writes + * to standard output, which gets closed. Note that there is no + * thread-local storage or IO subsystem after this call. + */ - Tcl_FinalizeThread(); + Tcl_FinalizeThread(); - /* - * Now finalize the Tcl execution environment. Note that this must be - * done after the exit handlers, because there are order dependencies. - */ + /* + * Now finalize the Tcl execution environment. Note that this must be done + * after the exit handlers, because there are order dependencies. + */ - TclFinalizeCompilation(); - TclFinalizeExecution(); - TclFinalizeEnvironment(); + TclFinalizeCompilation(); + TclFinalizeExecution(); + TclFinalizeEnvironment(); - /* - * Finalizing the filesystem must come after anything which might - * conceivably interact with the 'Tcl_FS' API. - */ + /* + * Finalizing the filesystem must come after anything which might + * conceivably interact with the 'Tcl_FS' API. + */ - TclFinalizeFilesystem(); + TclFinalizeFilesystem(); - /* - * Undo all Tcl_ObjType registrations, and reset the master list - * of free Tcl_Obj's. After this returns, no more Tcl_Obj's should - * be allocated or freed. - * - * Note in particular that TclFinalizeObjects() must follow - * TclFinalizeFilesystem() because TclFinalizeFilesystem free's - * the Tcl_Obj that holds the path of the current working directory. - */ + /* + * Undo all Tcl_ObjType registrations, and reset the master list of free + * Tcl_Obj's. After this returns, no more Tcl_Obj's should be allocated or + * freed. + * + * Note in particular that TclFinalizeObjects() must follow + * TclFinalizeFilesystem() because TclFinalizeFilesystem free's the + * Tcl_Obj that holds the path of the current working directory. + */ - TclFinalizeObjects(); + TclFinalizeObjects(); - /* - * We must be sure the encoding finalization doesn't need to examine - * the filesystem in any way. Since it only needs to clean up - * internal data structures, this is fine. - */ + /* + * We must be sure the encoding finalization doesn't need to examine the + * filesystem in any way. Since it only needs to clean up internal data + * structures, this is fine. + */ - TclFinalizeEncodingSubsystem(); + TclFinalizeEncodingSubsystem(); - Tcl_SetPanicProc(NULL); + Tcl_SetPanicProc(NULL); - /* - * Repeat finalization of the thread local storage once more. Although - * this step is already done by the Tcl_FinalizeThread call above, - * series of events happening afterwards may re-initialize TSD slots. - * Those need to be finalized again, otherwise we're leaking memory - * chunks. Very important to note is that things happening afterwards - * should not reference anything which may re-initialize TSD's. This - * includes freeing Tcl_Objs's, among other things. - * - * This fixes the Tcl Bug #990552. - */ + /* + * Repeat finalization of the thread local storage once more. Although + * this step is already done by the Tcl_FinalizeThread call above, series + * of events happening afterwards may re-initialize TSD slots. Those need + * to be finalized again, otherwise we're leaking memory chunks. Very + * important to note is that things happening afterwards should not + * reference anything which may re-initialize TSD's. This includes freeing + * Tcl_Objs's, among other things. + * + * This fixes the Tcl Bug #990552. + */ - TclFinalizeThreadData(); + TclFinalizeThreadData(); - /* - * Now we can free constants for conversions to/from double. - */ + /* + * Now we can free constants for conversions to/from double. + */ - TclFinalizeDoubleConversion(); - - /* - * There have been several bugs in the past that cause exit handlers - * to be established during Tcl_Finalize processing. Such exit - * handlers leave malloc'ed memory, and Tcl_FinalizeThreadAlloc or - * Tcl_FinalizeMemorySubsystem will result in a corrupted heap. The - * result can be a mysterious crash on process exit. Check here that - * nobody's done this. - */ + TclFinalizeDoubleConversion(); - if (firstExitPtr != NULL) { - Tcl_Panic("exit handlers were created during Tcl_Finalize"); - } + /* + * There have been several bugs in the past that cause exit handlers to be + * established during Tcl_Finalize processing. Such exit handlers leave + * malloc'ed memory, and Tcl_FinalizeThreadAlloc or + * Tcl_FinalizeMemorySubsystem will result in a corrupted heap. The result + * can be a mysterious crash on process exit. Check here that nobody's + * done this. + */ - TclFinalizePreserve(); + if (firstExitPtr != NULL) { + Tcl_Panic("exit handlers were created during Tcl_Finalize"); + } - /* - * Free synchronization objects. There really should only be one - * thread alive at this moment. - */ + TclFinalizePreserve(); + + /* + * Free synchronization objects. There really should only be one thread + * alive at this moment. + */ + + TclFinalizeSynchronization(); - TclFinalizeSynchronization(); + /* + * Close down the thread-specific object allocator. + */ #if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) - TclFinalizeThreadAlloc(); + TclFinalizeThreadAlloc(); #endif - /* - * We defer unloading of packages until very late to avoid memory - * access issues. Both exit callbacks and synchronization variables - * may be stored in packages. - * - * Note that TclFinalizeLoad unloads packages in the reverse of the - * order they were loaded in (i.e. last to be loaded is the first to - * be unloaded). This can be important for correct unloading when - * dependencies exist. - * - * Once load has been finalized, we will have deleted any temporary - * copies of shared libraries and can therefore reset the filesystem - * to its original state. - */ - TclFinalizeLoad(); - TclResetFilesystem(); + /* + * We defer unloading of packages until very late to avoid memory access + * issues. Both exit callbacks and synchronization variables may be stored + * in packages. + * + * Note that TclFinalizeLoad unloads packages in the reverse of the order + * they were loaded in (i.e. last to be loaded is the first to be + * unloaded). This can be important for correct unloading when + * dependencies exist. + * + * Once load has been finalized, we will have deleted any temporary copies + * of shared libraries and can therefore reset the filesystem to its + * original state. + */ - /* - * At this point, there should no longer be any ckalloc'ed memory. - */ + TclFinalizeLoad(); + TclResetFilesystem(); - TclFinalizeMemorySubsystem(); - inFinalize = 0; - } + /* + * At this point, there should no longer be any ckalloc'ed memory. + */ + + TclFinalizeMemorySubsystem(); + inFinalize = 0; + + alreadyFinalized: TclFinalizeLock(); } @@ -1000,18 +1012,18 @@ Tcl_Finalize() */ void -Tcl_FinalizeThread() +Tcl_FinalizeThread(void) { ExitHandler *exitPtr; - /* - * We use TclThreadDataKeyGet here, rather than Tcl_GetThreadData, - * because we don't want to initialize the data block if it hasn't - * been initialized already. + /* + * We use TclThreadDataKeyGet here, rather than Tcl_GetThreadData, because + * we don't want to initialize the data block if it hasn't been + * initialized already. */ - ThreadSpecificData *tsdPtr = - (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) + TclThreadDataKeyGet(&dataKey); if (tsdPtr != NULL) { tsdPtr->inExit = 1; @@ -1020,7 +1032,7 @@ Tcl_FinalizeThread() exitPtr = tsdPtr->firstExitPtr) { /* * Be careful to remove the handler from the list before invoking - * its callback. This protects us against double-freeing if the + * its callback. This protects us against double-freeing if the * callback should call Tcl_DeleteThreadExitHandler on itself. */ @@ -1063,7 +1075,7 @@ Tcl_FinalizeThread() */ int -TclInExit() +TclInExit(void) { return inFinalize; } @@ -1085,7 +1097,7 @@ TclInExit() */ int -TclInThreadExit() +TclInThreadExit(void) { ThreadSpecificData *tsdPtr = (ThreadSpecificData *) TclThreadDataKeyGet(&dataKey); @@ -1101,7 +1113,7 @@ TclInThreadExit() * * Tcl_VwaitObjCmd -- * - * This procedure is invoked to process the "vwait" Tcl command. See the + * This function is invoked to process the "vwait" Tcl command. See the * user documentation for details on what it does. * * Results: @@ -1115,11 +1127,11 @@ TclInThreadExit() /* ARGSUSED */ int -Tcl_VwaitObjCmd(clientData, interp, objc, objv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_VwaitObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { int done, foundEvent; char *nameString; @@ -1156,7 +1168,7 @@ Tcl_VwaitObjCmd(clientData, interp, objc, objv) Tcl_ResetResult(interp); if (!foundEvent) { Tcl_AppendResult(interp, "can't wait for variable \"", nameString, - "\": would wait forever", (char *) NULL); + "\": would wait forever", NULL); return TCL_ERROR; } return TCL_OK; @@ -1164,17 +1176,17 @@ Tcl_VwaitObjCmd(clientData, interp, objc, objv) /* ARGSUSED */ static char * -VwaitVarProc(clientData, interp, name1, name2, flags) - ClientData clientData; /* Pointer to integer to set to 1. */ - Tcl_Interp *interp; /* Interpreter containing variable. */ - CONST char *name1; /* Name of variable. */ - CONST char *name2; /* Second part of variable name. */ - int flags; /* Information about what happened. */ +VwaitVarProc( + ClientData clientData, /* Pointer to integer to set to 1. */ + Tcl_Interp *interp, /* Interpreter containing variable. */ + CONST char *name1, /* Name of variable. */ + CONST char *name2, /* Second part of variable name. */ + int flags) /* Information about what happened. */ { int *donePtr = (int *) clientData; *donePtr = 1; - return (char *) NULL; + return NULL; } /* @@ -1182,8 +1194,8 @@ VwaitVarProc(clientData, interp, name1, name2, flags) * * Tcl_UpdateObjCmd -- * - * This procedure is invoked to process the "update" Tcl command. See - * the user documentation for details on what it does. + * This function is invoked to process the "update" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -1196,15 +1208,15 @@ VwaitVarProc(clientData, interp, name1, name2, flags) /* ARGSUSED */ int -Tcl_UpdateObjCmd(clientData, interp, objc, objv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_UpdateObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { int optionIndex; int flags = 0; /* Initialized to avoid compiler warning. */ - static CONST char *updateOptions[] = {"idletasks", (char *) NULL}; + static CONST char *updateOptions[] = {"idletasks", NULL}; enum updateOptions {REGEXP_IDLETASKS}; if (objc == 1) { @@ -1225,7 +1237,7 @@ Tcl_UpdateObjCmd(clientData, interp, objc, objv) Tcl_WrongNumArgs(interp, 1, objv, "?idletasks?"); return TCL_ERROR; } - + while (Tcl_DoOneEvent(flags) != 0) { if (Tcl_LimitExceeded(interp)) { Tcl_ResetResult(interp); @@ -1247,7 +1259,7 @@ Tcl_UpdateObjCmd(clientData, interp, objc, objv) /* *----------------------------------------------------------------------------- * - * NewThreadProc -- + * NewThreadProc -- * * Bootstrap function of a new Tcl thread. * @@ -1261,16 +1273,17 @@ Tcl_UpdateObjCmd(clientData, interp, objc, objv) */ static Tcl_ThreadCreateType -NewThreadProc(ClientData clientData) +NewThreadProc( + ClientData clientData) { ThreadClientData *cdPtr; ClientData threadClientData; Tcl_ThreadCreateProc *threadProc; - cdPtr = (ThreadClientData *)clientData; + cdPtr = (ThreadClientData *) clientData; threadProc = cdPtr->proc; threadClientData = cdPtr->clientData; - Tcl_Free((char*)clientData); /* Allocated in Tcl_CreateThread() */ + Tcl_Free((char *) clientData); /* Allocated in Tcl_CreateThread() */ (*threadProc)(threadClientData); @@ -1283,12 +1296,12 @@ NewThreadProc(ClientData clientData) * * Tcl_CreateThread -- * - * This procedure creates a new thread. This actually belongs to the + * This function creates a new thread. This actually belongs to the * tclThread.c file but since we use some private data structures local * to this file, it is placed here. * * Results: - * TCL_OK if the thread could be created. The thread ID is returned in a + * TCL_OK if the thread could be created. The thread ID is returned in a * parameter. * * Side effects: @@ -1298,13 +1311,13 @@ NewThreadProc(ClientData clientData) */ int -Tcl_CreateThread(idPtr, proc, clientData, stackSize, flags) - Tcl_ThreadId *idPtr; /* Return, the ID of the thread */ - Tcl_ThreadCreateProc proc; /* Main() function of the thread */ - ClientData clientData; /* The one argument to Main() */ - int stackSize; /* Size of stack for the new thread */ - int flags; /* Flags controlling behaviour of the - * new thread. */ +Tcl_CreateThread( + Tcl_ThreadId *idPtr, /* Return, the ID of the thread */ + Tcl_ThreadCreateProc proc, /* Main() function of the thread */ + ClientData clientData, /* The one argument to Main() */ + int stackSize, /* Size of stack for the new thread */ + int flags) /* Flags controlling behaviour of the new + * thread. */ { #ifdef TCL_THREADS ThreadClientData *cdPtr; @@ -1313,7 +1326,7 @@ Tcl_CreateThread(idPtr, proc, clientData, stackSize, flags) cdPtr->proc = proc; cdPtr->clientData = clientData; - return TclpThreadCreate(idPtr, NewThreadProc, (ClientData)cdPtr, + return TclpThreadCreate(idPtr, NewThreadProc, (ClientData) cdPtr, stackSize, flags); #else return TCL_ERROR; diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 3c79e85..516ffcf 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclFCmd.c,v 1.35 2005/07/24 22:56:43 dkf Exp $ + * RCS: @(#) $Id: tclFCmd.c,v 1.36 2005/11/01 15:30:52 dkf Exp $ */ #include "tclInt.h" @@ -18,15 +18,14 @@ * Declarations for local functions defined in this file: */ -static int CopyRenameOneFile _ANSI_ARGS_((Tcl_Interp *interp, +static int CopyRenameOneFile(Tcl_Interp *interp, Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr, - int copyFlag, int force)); -static Tcl_Obj * FileBasename _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *pathPtr)); -static int FileCopyRename _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[], int copyFlag)); -static int FileForceOption _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[], int *forcePtr)); + int copyFlag, int force); +static Tcl_Obj * FileBasename(Tcl_Interp *interp, Tcl_Obj *pathPtr); +static int FileCopyRename(Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[], int copyFlag); +static int FileForceOption(Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[], int *forcePtr); /* *--------------------------------------------------------------------------- @@ -48,10 +47,11 @@ static int FileForceOption _ANSI_ARGS_((Tcl_Interp *interp, */ int -TclFileRenameCmd(interp, objc, objv) - Tcl_Interp *interp; /* Interp for error reporting. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */ +TclFileRenameCmd( + Tcl_Interp *interp, /* Interp for error reporting or recursive + * calls in the case of a tricky rename. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument strings passed to Tcl_FileCmd. */ { return FileCopyRename(interp, objc, objv, 0); } @@ -75,10 +75,11 @@ TclFileRenameCmd(interp, objc, objv) */ int -TclFileCopyCmd(interp, objc, objv) - Tcl_Interp *interp; /* Used for error reporting */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */ +TclFileCopyCmd( + Tcl_Interp *interp, /* Used for error reporting or recursive calls + * in the case of a tricky copy. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument strings passed to Tcl_FileCmd. */ { return FileCopyRename(interp, objc, objv, 1); } @@ -101,11 +102,11 @@ TclFileCopyCmd(interp, objc, objv) */ static int -FileCopyRename(interp, objc, objv, copyFlag) - Tcl_Interp *interp; /* Used for error reporting. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */ - int copyFlag; /* If non-zero, copy source(s). Otherwise, +FileCopyRename( + Tcl_Interp *interp, /* Used for error reporting. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[], /* Argument strings passed to Tcl_FileCmd. */ + int copyFlag) /* If non-zero, copy source(s). Otherwise, * rename them. */ { int i, result, force; @@ -120,8 +121,7 @@ FileCopyRename(interp, objc, objv, copyFlag) if ((objc - i) < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", TclGetString(objv[0]), " ", TclGetString(objv[1]), - " ?options? source ?source ...? target\"", - (char *) NULL); + " ?options? source ?source ...? target\"", NULL); return TCL_ERROR; } @@ -149,9 +149,8 @@ FileCopyRename(interp, objc, objv, copyFlag) errno = ENOTDIR; Tcl_PosixError(interp); Tcl_AppendResult(interp, "error ", - ((copyFlag) ? "copying" : "renaming"), ": target \"", - TclGetString(target), "\" is not a directory", - (char *) NULL); + (copyFlag ? "copying" : "renaming"), ": target \"", + TclGetString(target), "\" is not a directory", NULL); result = TCL_ERROR; } else { /* @@ -216,11 +215,12 @@ FileCopyRename(interp, objc, objv, copyFlag) * *---------------------------------------------------------------------- */ + int -TclFileMakeDirsCmd(interp, objc, objv) - Tcl_Interp *interp; /* Used for error reporting. */ - int objc; /* Number of arguments */ - Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */ +TclFileMakeDirsCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + int objc, /* Number of arguments */ + Tcl_Obj *CONST objv[]) /* Argument strings passed to Tcl_FileCmd. */ { Tcl_Obj *errfile; int result, i, j, pobjc; @@ -307,8 +307,7 @@ TclFileMakeDirsCmd(interp, objc, objv) done: if (errfile != NULL) { Tcl_AppendResult(interp, "can't create directory \"", - TclGetString(errfile), "\": ", Tcl_PosixError(interp), - (char *) NULL); + TclGetString(errfile), "\": ", Tcl_PosixError(interp), NULL); result = TCL_ERROR; } if (split != NULL) { @@ -338,10 +337,10 @@ TclFileMakeDirsCmd(interp, objc, objv) */ int -TclFileDeleteCmd(interp, objc, objv) - Tcl_Interp *interp; /* Used for error reporting */ - int objc; /* Number of arguments */ - Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */ +TclFileDeleteCmd( + Tcl_Interp *interp, /* Used for error reporting */ + int objc, /* Number of arguments */ + Tcl_Obj *CONST objv[]) /* Argument strings passed to Tcl_FileCmd. */ { int i, force, result; Tcl_Obj *errfile; @@ -355,7 +354,7 @@ TclFileDeleteCmd(interp, objc, objv) if ((objc - i) < 1) { Tcl_AppendResult(interp, "wrong # args: should be \"", TclGetString(objv[0]), " ", TclGetString(objv[1]), - " ?options? file ?file ...?\"", (char *) NULL); + " ?options? file ?file ...?\"", NULL); return TCL_ERROR; } @@ -395,7 +394,7 @@ TclFileDeleteCmd(interp, objc, objv) if ((force == 0) && (errno == EEXIST)) { Tcl_AppendResult(interp, "error deleting \"", TclGetString(objv[i]), "\": directory not empty", - (char *) NULL); + NULL); Tcl_PosixError(interp); goto done; } @@ -436,11 +435,11 @@ TclFileDeleteCmd(interp, objc, objv) */ Tcl_AppendResult(interp, "error deleting unknown file: ", - Tcl_PosixError(interp), (char *) NULL); + Tcl_PosixError(interp), NULL); } else { Tcl_AppendResult(interp, "error deleting \"", TclGetString(errfile), "\": ", Tcl_PosixError(interp), - (char *) NULL); + NULL); } } @@ -471,15 +470,15 @@ TclFileDeleteCmd(interp, objc, objv) */ static int -CopyRenameOneFile(interp, source, target, copyFlag, force) - Tcl_Interp *interp; /* Used for error reporting. */ - Tcl_Obj *source; /* Pathname of file to copy. May need to be +CopyRenameOneFile( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Obj *source, /* Pathname of file to copy. May need to be * translated. */ - Tcl_Obj *target; /* Pathname of file to create/overwrite. May + Tcl_Obj *target, /* Pathname of file to create/overwrite. May * need to be translated. */ - int copyFlag; /* If non-zero, copy files. Otherwise, rename + int copyFlag, /* If non-zero, copy files. Otherwise, rename * them. */ - int force; /* If non-zero, overwrite target file if it + int force) /* If non-zero, overwrite target file if it * exists. Otherwise, error if target already * exists. */ { @@ -549,7 +548,7 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) errno = EISDIR; Tcl_AppendResult(interp, "can't overwrite file \"", TclGetString(target), "\" with directory \"", - TclGetString(source), "\"", (char *) NULL); + TclGetString(source), "\"", NULL); goto done; } if (!S_ISDIR(sourceStatBuf.st_mode) @@ -557,7 +556,7 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) errno = EISDIR; Tcl_AppendResult(interp, "can't overwrite directory \"", TclGetString(target), "\" with file \"", - TclGetString(source), "\"", (char *) NULL); + TclGetString(source), "\"", NULL); goto done; } @@ -589,7 +588,7 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) Tcl_AppendResult(interp, "error renaming \"", TclGetString(source), "\" to \"", TclGetString(target), "\": trying to rename a volume or ", - "move a directory into itself", (char *) NULL); + "move a directory into itself", NULL); goto done; } else if (errno != EXDEV) { errfile = target; @@ -634,8 +633,7 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) */ Tcl_AppendResult(interp, "error copying \"", TclGetString(source), - "\": the target of this link doesn't exist", - (char *) NULL); + "\": the target of this link doesn't exist", NULL); goto done; } else { int counter = 0; @@ -682,7 +680,7 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) /* Now 'actualSource' is the correct file */ } } -#endif +#endif /* S_ISLNK */ #endif if (S_ISDIR(sourceStatBuf.st_mode)) { @@ -694,7 +692,8 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) * cross-filesystem copy. We do this through our Tcl library. */ - Tcl_Obj *copyCommand = Tcl_NewListObj(0,NULL); + Tcl_Obj *copyCommand = Tcl_NewListObj(0, NULL); + Tcl_IncrRefCount(copyCommand); Tcl_ListObjAppendElement(interp, copyCommand, Tcl_NewStringObj("::tcl::CopyDirectory",-1)); @@ -769,26 +768,22 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) } if (result != TCL_OK) { Tcl_AppendResult(interp, "can't unlink \"", TclGetString(errfile), - "\": ", Tcl_PosixError(interp), (char *) NULL); + "\": ", Tcl_PosixError(interp), NULL); errfile = NULL; } } done: if (errfile != NULL) { - Tcl_AppendResult(interp, - ((copyFlag) ? "error copying \"" : "error renaming \""), - TclGetString(source), (char *) NULL); + Tcl_AppendResult(interp, "error ", (copyFlag ? "copying" : "renaming"), + " \"", TclGetString(source), NULL); if (errfile != source) { - Tcl_AppendResult(interp, "\" to \"", TclGetString(target), - (char *) NULL); + Tcl_AppendResult(interp, "\" to \"", TclGetString(target), NULL); if (errfile != target) { - Tcl_AppendResult(interp, "\": \"", TclGetString(errfile), - (char *) NULL); + Tcl_AppendResult(interp, "\": \"", TclGetString(errfile),NULL); } } - Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp), - (char *) NULL); + Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp), NULL); } if (errorBuffer != NULL) { Tcl_DecrRefCount(errorBuffer); @@ -819,12 +814,12 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) */ static int -FileForceOption(interp, objc, objv, forcePtr) - Tcl_Interp *interp; /* Interp, for error return. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument strings. First command line +FileForceOption( + Tcl_Interp *interp, /* Interp, for error return. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[], /* Argument strings. First command line * option, if it exists, begins at 0. */ - int *forcePtr; /* If the "-force" was specified, *forcePtr is + int *forcePtr) /* If the "-force" was specified, *forcePtr is * filled with 1, otherwise with 0. */ { int force, i; @@ -841,7 +836,7 @@ FileForceOption(interp, objc, objv, forcePtr) break; } else { Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[i]), - "\": should be -force or --", (char *)NULL); + "\": should be -force or --", NULL); return -1; } } @@ -869,9 +864,9 @@ FileForceOption(interp, objc, objv, forcePtr) */ static Tcl_Obj * -FileBasename(interp, pathPtr) - Tcl_Interp *interp; /* Interp, for error return. */ - Tcl_Obj *pathPtr; /* Path whose basename to extract. */ +FileBasename( + Tcl_Interp *interp, /* Interp, for error return. */ + Tcl_Obj *pathPtr) /* Path whose basename to extract. */ { int objc; Tcl_Obj *splitPtr; @@ -945,10 +940,10 @@ FileBasename(interp, pathPtr) */ int -TclFileAttrsCmd(interp, objc, objv) - Tcl_Interp *interp; /* The interpreter for error reporting. */ - int objc; /* Number of command line arguments. */ - Tcl_Obj *CONST objv[]; /* The command line objects. */ +TclFileAttrsCmd( + Tcl_Interp *interp, /* The interpreter for error reporting. */ + int objc, /* Number of command line arguments. */ + Tcl_Obj *CONST objv[]) /* The command line objects. */ { int result; CONST char ** attributeStrings; @@ -985,7 +980,7 @@ TclFileAttrsCmd(interp, objc, objv) */ Tcl_AppendResult(interp, "could not read \"", TclGetString(filePtr), "\": ", Tcl_PosixError(interp), - (char *) NULL); + NULL); return TCL_ERROR; } goto end; @@ -1064,7 +1059,7 @@ TclFileAttrsCmd(interp, objc, objv) if (numObjStrings == 0) { Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[0]), "\", there are no file attributes in this filesystem.", - (char *) NULL); + NULL); goto end; } @@ -1087,7 +1082,7 @@ TclFileAttrsCmd(interp, objc, objv) if (numObjStrings == 0) { Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[0]), "\", there are no file attributes in this filesystem.", - (char *) NULL); + NULL); goto end; } @@ -1098,7 +1093,7 @@ TclFileAttrsCmd(interp, objc, objv) } if (i + 1 == objc) { Tcl_AppendResult(interp, "value for \"", - TclGetString(objv[i]), "\" missing", (char *) NULL); + TclGetString(objv[i]), "\" missing", NULL); goto end; } if (Tcl_FSFileAttrsSet(interp, index, filePtr, diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 9a7d308..b6232ac 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIOCmd.c,v 1.31 2005/08/24 17:56:23 andreas_kupries Exp $ + * RCS: @(#) $Id: tclIOCmd.c,v 1.32 2005/11/01 15:30:52 dkf Exp $ */ #include "tclInt.h" @@ -26,22 +26,23 @@ typedef struct AcceptCallback { * Static functions for this file: */ -static void AcceptCallbackProc _ANSI_ARGS_((ClientData callbackData, - Tcl_Channel chan, char *address, int port)); -static void RegisterTcpServerInterpCleanup _ANSI_ARGS_((Tcl_Interp *interp, - AcceptCallback *acceptCallbackPtr)); -static void TcpAcceptCallbacksDeleteProc _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp)); -static void TcpServerCloseProc _ANSI_ARGS_((ClientData callbackData)); -static void UnregisterTcpServerInterpCleanupProc _ANSI_ARGS_(( - Tcl_Interp *interp, AcceptCallback *acceptCallbackPtr)); +static void AcceptCallbackProc(ClientData callbackData, + Tcl_Channel chan, char *address, int port); +static void RegisterTcpServerInterpCleanup(Tcl_Interp *interp, + AcceptCallback *acceptCallbackPtr); +static void TcpAcceptCallbacksDeleteProc(ClientData clientData, + Tcl_Interp *interp); +static void TcpServerCloseProc(ClientData callbackData); +static void UnregisterTcpServerInterpCleanupProc( + Tcl_Interp *interp, + AcceptCallback *acceptCallbackPtr); /* *---------------------------------------------------------------------- * * Tcl_PutsObjCmd -- * - * This procedure is invoked to process the "puts" Tcl command. See the + * This function is invoked to process the "puts" Tcl command. See the * user documentation for details on what it does. * * Results: @@ -55,11 +56,11 @@ static void UnregisterTcpServerInterpCleanupProc _ANSI_ARGS_(( /* ARGSUSED */ int -Tcl_PutsObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_PutsObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { Tcl_Channel chan; /* The channel to puts on. */ Tcl_Obj *string; /* String to write. */ @@ -101,9 +102,10 @@ Tcl_PutsObjCmd(dummy, interp, objc, objv) int length; arg = Tcl_GetStringFromObj(objv[3], &length); - if ((length != 9) || (strncmp(arg, "nonewline", (size_t) length) != 0)) { + if ((length != 9) + || (strncmp(arg, "nonewline", (size_t) length) != 0)) { Tcl_AppendResult(interp, "bad argument \"", arg, - "\": should be \"nonewline\"", (char *) NULL); + "\": should be \"nonewline\"", NULL); return TCL_ERROR; } channelId = Tcl_GetString(objv[1]); @@ -124,7 +126,7 @@ Tcl_PutsObjCmd(dummy, interp, objc, objv) } if ((mode & TCL_WRITABLE) == 0) { Tcl_AppendResult(interp, "channel \"", channelId, - "\" wasn't opened for writing", (char *) NULL); + "\" wasn't opened for writing", NULL); return TCL_ERROR; } @@ -140,15 +142,17 @@ Tcl_PutsObjCmd(dummy, interp, objc, objv) } return TCL_OK; - error: - /* TIP #219. + /* + * TIP #219. * Capture error messages put by the driver into the bypass area and put * them into the regular interpreter result. Fall back to the regular * message if nothing was found in the bypass. */ - if (!TclChanCaughtErrorBypass (interp, chan)) { + + error: + if (!TclChanCaughtErrorBypass(interp, chan)) { Tcl_AppendResult(interp, "error writing \"", channelId, "\": ", - Tcl_PosixError(interp), (char *) NULL); + Tcl_PosixError(interp), NULL); } return TCL_ERROR; } @@ -158,7 +162,7 @@ Tcl_PutsObjCmd(dummy, interp, objc, objv) * * Tcl_FlushObjCmd -- * - * This procedure is called to process the Tcl "flush" command. See the + * This function is called to process the Tcl "flush" command. See the * user documentation for details on what it does. * * Results: @@ -172,11 +176,11 @@ Tcl_PutsObjCmd(dummy, interp, objc, objv) /* ARGSUSED */ int -Tcl_FlushObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_FlushObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { Tcl_Channel chan; /* The channel to flush on. */ char *channelId; @@ -193,19 +197,21 @@ Tcl_FlushObjCmd(dummy, interp, objc, objv) } if ((mode & TCL_WRITABLE) == 0) { Tcl_AppendResult(interp, "channel \"", channelId, - "\" wasn't opened for writing", (char *) NULL); + "\" wasn't opened for writing", NULL); return TCL_ERROR; } if (Tcl_Flush(chan) != TCL_OK) { - /* TIP #219. + /* + * TIP #219. * Capture error messages put by the driver into the bypass area and * put them into the regular interpreter result. Fall back to the * regular message if nothing was found in the bypass. */ - if (!TclChanCaughtErrorBypass (interp, chan)) { + + if (!TclChanCaughtErrorBypass(interp, chan)) { Tcl_AppendResult(interp, "error flushing \"", channelId, "\": ", - Tcl_PosixError(interp), (char *) NULL); + Tcl_PosixError(interp), NULL); } return TCL_ERROR; } @@ -217,7 +223,7 @@ Tcl_FlushObjCmd(dummy, interp, objc, objv) * * Tcl_GetsObjCmd -- * - * This procedure is called to process the Tcl "gets" command. See the + * This function is called to process the Tcl "gets" command. See the * user documentation for details on what it does. * * Results: @@ -231,11 +237,11 @@ Tcl_FlushObjCmd(dummy, interp, objc, objv) /* ARGSUSED */ int -Tcl_GetsObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_GetsObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { Tcl_Channel chan; /* The channel to read from. */ int lineLen; /* Length of line just read. */ @@ -254,7 +260,7 @@ Tcl_GetsObjCmd(dummy, interp, objc, objv) } if ((mode & TCL_READABLE) == 0) { Tcl_AppendResult(interp, "channel \"", name, - "\" wasn't opened for reading", (char *) NULL); + "\" wasn't opened for reading", NULL); return TCL_ERROR; } @@ -265,15 +271,16 @@ Tcl_GetsObjCmd(dummy, interp, objc, objv) if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) { Tcl_DecrRefCount(linePtr); - /* TIP #219. + /* + * TIP #219. * Capture error messages put by the driver into the bypass area * and put them into the regular interpreter result. Fall back to * the regular message if nothing was found in the bypass. */ - if (!TclChanCaughtErrorBypass (interp, chan)) { + if (!TclChanCaughtErrorBypass(interp, chan)) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "error reading \"", name, "\": ", - Tcl_PosixError(interp), (char *) NULL); + Tcl_PosixError(interp), NULL); } return TCL_ERROR; } @@ -298,7 +305,7 @@ Tcl_GetsObjCmd(dummy, interp, objc, objv) * * Tcl_ReadObjCmd -- * - * This procedure is invoked to process the Tcl "read" command. See the + * This function is invoked to process the Tcl "read" command. See the * user documentation for details on what it does. * * Results: @@ -312,11 +319,11 @@ Tcl_GetsObjCmd(dummy, interp, objc, objv) /* ARGSUSED */ int -Tcl_ReadObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_ReadObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { Tcl_Channel chan; /* The channel to read from. */ int newline, i; /* Discard newline at end? */ @@ -362,7 +369,7 @@ Tcl_ReadObjCmd(dummy, interp, objc, objv) } if ((mode & TCL_READABLE) == 0) { Tcl_AppendResult(interp, "channel \"", name, - "\" wasn't opened for reading", (char *) NULL); + "\" wasn't opened for reading", NULL); return TCL_ERROR; } i++; /* Consumed channel name. */ @@ -385,7 +392,7 @@ Tcl_ReadObjCmd(dummy, interp, objc, objv) newline = 1; } else { Tcl_AppendResult(interp, "bad argument \"", arg, - "\": should be \"nonewline\"", (char *) NULL); + "\": should be \"nonewline\"", NULL); return TCL_ERROR; } } @@ -394,15 +401,17 @@ Tcl_ReadObjCmd(dummy, interp, objc, objv) Tcl_IncrRefCount(resultPtr); charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0); if (charactersRead < 0) { - /* TIP #219. + /* + * TIP #219. * Capture error messages put by the driver into the bypass area and * put them into the regular interpreter result. Fall back to the * regular message if nothing was found in the bypass. */ - if (!TclChanCaughtErrorBypass (interp, chan)) { + + if (!TclChanCaughtErrorBypass(interp, chan)) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "error reading \"", name, "\": ", - Tcl_PosixError(interp), (char *) NULL); + Tcl_PosixError(interp), NULL); Tcl_DecrRefCount(resultPtr); } return TCL_ERROR; @@ -431,7 +440,7 @@ Tcl_ReadObjCmd(dummy, interp, objc, objv) * * Tcl_SeekObjCmd -- * - * This procedure is invoked to process the Tcl "seek" command. See the + * This function is invoked to process the Tcl "seek" command. See the * user documentation for details on what it does. * * Results: @@ -446,20 +455,20 @@ Tcl_ReadObjCmd(dummy, interp, objc, objv) /* ARGSUSED */ int -Tcl_SeekObjCmd(clientData, interp, objc, objv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_SeekObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { - Tcl_Channel chan; /* The channel to tell on. */ - Tcl_WideInt offset; /* Where to seek? */ - int mode; /* How to seek? */ - Tcl_WideInt result; /* Of calling Tcl_Seek. */ + Tcl_Channel chan; /* The channel to tell on. */ + Tcl_WideInt offset; /* Where to seek? */ + int mode; /* How to seek? */ + Tcl_WideInt result; /* Of calling Tcl_Seek. */ char *chanName; int optionIndex; static CONST char *originOptions[] = { - "start", "current", "end", (char *) NULL + "start", "current", "end", NULL }; static int modeArray[] = {SEEK_SET, SEEK_CUR, SEEK_END}; @@ -486,15 +495,15 @@ Tcl_SeekObjCmd(clientData, interp, objc, objv) result = Tcl_Seek(chan, offset, mode); if (result == Tcl_LongAsWide(-1)) { - /* TIP #219. + /* + * TIP #219. * Capture error messages put by the driver into the bypass area and * put them into the regular interpreter result. Fall back to the * regular message if nothing was found in the bypass. */ - if (!TclChanCaughtErrorBypass (interp, chan)) { - Tcl_AppendResult(interp, "error during seek on \"", - chanName, "\": ", Tcl_PosixError(interp), - (char *) NULL); + if (!TclChanCaughtErrorBypass(interp, chan)) { + Tcl_AppendResult(interp, "error during seek on \"", chanName, + "\": ", Tcl_PosixError(interp), NULL); } return TCL_ERROR; } @@ -506,7 +515,7 @@ Tcl_SeekObjCmd(clientData, interp, objc, objv) * * Tcl_TellObjCmd -- * - * This procedure is invoked to process the Tcl "tell" command. See the + * This function is invoked to process the Tcl "tell" command. See the * user documentation for details on what it does. * * Results: @@ -520,13 +529,13 @@ Tcl_SeekObjCmd(clientData, interp, objc, objv) /* ARGSUSED */ int -Tcl_TellObjCmd(clientData, interp, objc, objv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_TellObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { - Tcl_Channel chan; /* The channel to tell on. */ + Tcl_Channel chan; /* The channel to tell on. */ char *chanName; Tcl_WideInt newLoc; @@ -548,11 +557,13 @@ Tcl_TellObjCmd(clientData, interp, objc, objv) newLoc = Tcl_Tell(chan); - /* TIP #219. + /* + * TIP #219. * Capture error messages put by the driver into the bypass area and put * them into the regular interpreter result. */ - if (TclChanCaughtErrorBypass (interp, chan)) { + + if (TclChanCaughtErrorBypass(interp, chan)) { return TCL_ERROR; } @@ -565,7 +576,7 @@ Tcl_TellObjCmd(clientData, interp, objc, objv) * * Tcl_CloseObjCmd -- * - * This procedure is invoked to process the Tcl "close" command. See the + * This function is invoked to process the Tcl "close" command. See the * user documentation for details on what it does. * * Results: @@ -579,13 +590,13 @@ Tcl_TellObjCmd(clientData, interp, objc, objv) /* ARGSUSED */ int -Tcl_CloseObjCmd(clientData, interp, objc, objv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_CloseObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { - Tcl_Channel chan; /* The channel to close. */ + Tcl_Channel chan; /* The channel to close. */ char *arg; if (objc != 2) { @@ -635,8 +646,8 @@ Tcl_CloseObjCmd(clientData, interp, objc, objv) * * Tcl_FconfigureObjCmd -- * - * This procedure is invoked to process the Tcl "fconfigure" command. - * See the user documentation for details on what it does. + * This function is invoked to process the Tcl "fconfigure" command. See + * the user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -649,17 +660,15 @@ Tcl_CloseObjCmd(clientData, interp, objc, objv) /* ARGSUSED */ int -Tcl_FconfigureObjCmd(clientData, interp, objc, objv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_FconfigureObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { char *chanName, *optionName, *valueName; - Tcl_Channel chan; /* The channel to set a mode on. */ - int i; /* Iterate over arg-value pairs. */ - Tcl_DString ds; /* DString to hold result of calling - * Tcl_GetChannelOption. */ + Tcl_Channel chan; /* The channel to set a mode on. */ + int i; /* Iterate over arg-value pairs. */ if ((objc < 2) || (((objc % 2) == 1) && (objc != 3))) { Tcl_WrongNumArgs(interp, 1, objv, @@ -674,14 +683,20 @@ Tcl_FconfigureObjCmd(clientData, interp, objc, objv) } if (objc == 2) { + Tcl_DString ds; /* DString to hold result of calling + * Tcl_GetChannelOption. */ + Tcl_DStringInit(&ds); - if (Tcl_GetChannelOption(interp, chan, (char *) NULL, &ds) != TCL_OK) { + if (Tcl_GetChannelOption(interp, chan, NULL, &ds) != TCL_OK) { Tcl_DStringFree(&ds); return TCL_ERROR; } Tcl_DStringResult(interp, &ds); return TCL_OK; } else if (objc == 3) { + Tcl_DString ds; /* DString to hold result of calling + * Tcl_GetChannelOption. */ + Tcl_DStringInit(&ds); optionName = Tcl_GetString(objv[2]); if (Tcl_GetChannelOption(interp, chan, optionName, &ds) != TCL_OK) { @@ -709,7 +724,7 @@ Tcl_FconfigureObjCmd(clientData, interp, objc, objv) * * Tcl_EofObjCmd -- * - * This procedure is invoked to process the Tcl "eof" command. See the + * This function is invoked to process the Tcl "eof" command. See the * user documentation for details on what it does. * * Results: @@ -724,11 +739,11 @@ Tcl_FconfigureObjCmd(clientData, interp, objc, objv) /* ARGSUSED */ int -Tcl_EofObjCmd(unused, interp, objc, objv) - ClientData unused; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_EofObjCmd( + ClientData unused, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { Tcl_Channel chan; int dummy; @@ -754,7 +769,7 @@ Tcl_EofObjCmd(unused, interp, objc, objv) * * Tcl_ExecObjCmd -- * - * This procedure is invoked to process the "exec" Tcl command. See the + * This function is invoked to process the "exec" Tcl command. See the * user documentation for details on what it does. * * Results: @@ -768,14 +783,14 @@ Tcl_EofObjCmd(unused, interp, objc, objv) /* ARGSUSED */ int -Tcl_ExecObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_ExecObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { /* - * This procedure generates an argv array for the string arguments. It + * This function generates an argv array for the string arguments. It * starts out with stack-allocated space but uses dynamically-allocated * storage if needed. */ @@ -788,7 +803,7 @@ Tcl_ExecObjCmd(dummy, interp, objc, objv) CONST char *argStorage[NUM_ARGS]; int argc, background, i, index, keepNewline, result, skip, length; static CONST char *options[] = { - "-keepnewline", "--", NULL + "-keepnewline", "--", NULL }; enum options { EXEC_KEEPNEWLINE, EXEC_LAST @@ -882,15 +897,17 @@ Tcl_ExecObjCmd(dummy, interp, objc, objv) resultPtr = Tcl_NewObj(); if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) { if (Tcl_ReadChars(chan, resultPtr, -1, 0) < 0) { - /* TIP #219. + /* + * TIP #219. * Capture error messages put by the driver into the bypass area * and put them into the regular interpreter result. Fall back to * the regular message if nothing was found in the bypass. */ + if (!TclChanCaughtErrorBypass (interp, chan)) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "error reading output from command: ", - Tcl_PosixError(interp), (char *) NULL); + Tcl_PosixError(interp), NULL); Tcl_DecrRefCount(resultPtr); } return TCL_ERROR; @@ -899,7 +916,7 @@ Tcl_ExecObjCmd(dummy, interp, objc, objv) /* * If the process produced anything on stderr, it will have been returned - * in the interpreter result. It needs to be appended to the result + * in the interpreter result. It needs to be appended to the result * string. */ @@ -927,7 +944,7 @@ Tcl_ExecObjCmd(dummy, interp, objc, objv) * * Tcl_FblockedObjCmd -- * - * This procedure is invoked to process the Tcl "fblocked" command. See + * This function is invoked to process the Tcl "fblocked" command. See * the user documentation for details on what it does. * * Results: @@ -942,11 +959,11 @@ Tcl_ExecObjCmd(dummy, interp, objc, objv) /* ARGSUSED */ int -Tcl_FblockedObjCmd(unused, interp, objc, objv) - ClientData unused; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_FblockedObjCmd( + ClientData unused, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { Tcl_Channel chan; int mode; @@ -964,7 +981,7 @@ Tcl_FblockedObjCmd(unused, interp, objc, objv) } if ((mode & TCL_READABLE) == 0) { Tcl_AppendResult(interp, "channel \"", arg, - "\" wasn't opened for reading", (char *) NULL); + "\" wasn't opened for reading", NULL); return TCL_ERROR; } @@ -977,7 +994,7 @@ Tcl_FblockedObjCmd(unused, interp, objc, objv) * * Tcl_OpenObjCmd -- * - * This procedure is invoked to process the "open" Tcl command. See the + * This function is invoked to process the "open" Tcl command. See the * user documentation for details on what it does. * * Results: @@ -991,11 +1008,11 @@ Tcl_FblockedObjCmd(unused, interp, objc, objv) /* ARGSUSED */ int -Tcl_OpenObjCmd(notUsed, interp, objc, objv) - ClientData notUsed; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_OpenObjCmd( + ClientData notUsed, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { int pipeline, prot; char *modeString, *what; @@ -1068,7 +1085,7 @@ Tcl_OpenObjCmd(notUsed, interp, objc, objv) return TCL_ERROR; } Tcl_RegisterChannel(interp, chan); - Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL); + Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL); return TCL_OK; } @@ -1095,10 +1112,10 @@ Tcl_OpenObjCmd(notUsed, interp, objc, objv) /* ARGSUSED */ static void -TcpAcceptCallbacksDeleteProc(clientData, interp) - ClientData clientData; /* Data which was passed when the assocdata +TcpAcceptCallbacksDeleteProc( + ClientData clientData, /* Data which was passed when the assocdata * was registered. */ - Tcl_Interp *interp; /* Interpreter being deleted - not used. */ + Tcl_Interp *interp) /* Interpreter being deleted - not used. */ { Tcl_HashTable *hTblPtr; Tcl_HashEntry *hPtr; @@ -1107,10 +1124,9 @@ TcpAcceptCallbacksDeleteProc(clientData, interp) hTblPtr = (Tcl_HashTable *) clientData; for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); - hPtr != (Tcl_HashEntry *) NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { + hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { acceptCallbackPtr = (AcceptCallback *) Tcl_GetHashValue(hPtr); - acceptCallbackPtr->interp = (Tcl_Interp *) NULL; + acceptCallbackPtr->interp = NULL; } Tcl_DeleteHashTable(hTblPtr); ckfree((char *) hTblPtr); @@ -1136,10 +1152,10 @@ TcpAcceptCallbacksDeleteProc(clientData, interp) */ static void -RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr) - Tcl_Interp *interp; /* Interpreter for which we want to be +RegisterTcpServerInterpCleanup( + Tcl_Interp *interp, /* Interpreter for which we want to be * informed of deletion. */ - AcceptCallback *acceptCallbackPtr; + AcceptCallback *acceptCallbackPtr) /* The accept callback record whose interp * field we want set to NULL when the * interpreter is deleted. */ @@ -1150,14 +1166,16 @@ RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr) Tcl_HashEntry *hPtr; /* Entry for this record. */ int new; /* Is the entry new? */ - hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, - "tclTCPAcceptCallbacks", NULL); - if (hTblPtr == (Tcl_HashTable *) NULL) { + hTblPtr = (Tcl_HashTable *) + Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL); + + if (hTblPtr == NULL) { hTblPtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable)); Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS); (void) Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks", TcpAcceptCallbacksDeleteProc, (ClientData) hTblPtr); } + hPtr = Tcl_CreateHashEntry(hTblPtr, (char *) acceptCallbackPtr, &new); if (!new) { Tcl_Panic("RegisterTcpServerCleanup: damaged accept record table"); @@ -1185,10 +1203,10 @@ RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr) */ static void -UnregisterTcpServerInterpCleanupProc(interp, acceptCallbackPtr) - Tcl_Interp *interp; /* Interpreter in which the accept callback +UnregisterTcpServerInterpCleanupProc( + Tcl_Interp *interp, /* Interpreter in which the accept callback * record was registered. */ - AcceptCallback *acceptCallbackPtr; + AcceptCallback *acceptCallbackPtr) /* The record for which to delete the * registration. */ { @@ -1197,14 +1215,14 @@ UnregisterTcpServerInterpCleanupProc(interp, acceptCallbackPtr) hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL); - if (hTblPtr == (Tcl_HashTable *) NULL) { + if (hTblPtr == NULL) { return; } + hPtr = Tcl_FindHashEntry(hTblPtr, (char *) acceptCallbackPtr); - if (hPtr == (Tcl_HashEntry *) NULL) { - return; + if (hPtr != NULL) { + Tcl_DeleteHashEntry(hPtr); } - Tcl_DeleteHashEntry(hPtr); } /* @@ -1225,15 +1243,14 @@ UnregisterTcpServerInterpCleanupProc(interp, acceptCallbackPtr) */ static void -AcceptCallbackProc(callbackData, chan, address, port) - ClientData callbackData; /* The data stored when the callback - * was created in the call to - * Tcl_OpenTcpServer. */ - Tcl_Channel chan; /* Channel for the newly accepted - * connection. */ - char *address; /* Address of client that was - * accepted. */ - int port; /* Port of client that was accepted. */ +AcceptCallbackProc( + ClientData callbackData, /* The data stored when the callback was + * created in the call to + * Tcl_OpenTcpServer. */ + Tcl_Channel chan, /* Channel for the newly accepted + * connection. */ + char *address, /* Address of client that was accepted. */ + int port) /* Port of client that was accepted. */ { AcceptCallback *acceptCallbackPtr; Tcl_Interp *interp; @@ -1249,7 +1266,7 @@ AcceptCallbackProc(callbackData, chan, address, port) * data to NULL. */ - if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) { + if (acceptCallbackPtr->interp != NULL) { script = acceptCallbackPtr->script; interp = acceptCallbackPtr->interp; @@ -1265,10 +1282,10 @@ AcceptCallbackProc(callbackData, chan, address, port) * deleted while the script is being evaluated. */ - Tcl_RegisterChannel((Tcl_Interp *) NULL, chan); + Tcl_RegisterChannel(NULL, chan); result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan), - " ", address, " ", portBuf, (char *) NULL); + " ", address, " ", portBuf, NULL); if (result != TCL_OK) { Tcl_BackgroundError(interp); Tcl_UnregisterChannel(interp, chan); @@ -1279,18 +1296,18 @@ AcceptCallbackProc(callbackData, chan, address, port) * safe anymore to use "chan", because it may now be deleted. */ - Tcl_UnregisterChannel((Tcl_Interp *) NULL, chan); + Tcl_UnregisterChannel(NULL, chan); Tcl_Release((ClientData) interp); Tcl_Release((ClientData) script); - } else { + } else { /* * The interpreter has been deleted, so there is no useful way to * utilize the client socket - just close it. */ - Tcl_Close((Tcl_Interp *) NULL, chan); + Tcl_Close(NULL, chan); } } @@ -1316,15 +1333,15 @@ AcceptCallbackProc(callbackData, chan, address, port) */ static void -TcpServerCloseProc(callbackData) - ClientData callbackData; /* The data passed in the call to +TcpServerCloseProc( + ClientData callbackData) /* The data passed in the call to * Tcl_CreateCloseHandler. */ { AcceptCallback *acceptCallbackPtr; /* The actual data. */ acceptCallbackPtr = (AcceptCallback *) callbackData; - if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) { + if (acceptCallbackPtr->interp != NULL) { UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp, acceptCallbackPtr); } @@ -1337,8 +1354,8 @@ TcpServerCloseProc(callbackData) * * Tcl_SocketObjCmd -- * - * This procedure is invoked to process the "socket" Tcl command. See - * the user documentation for details on what it does. + * This function is invoked to process the "socket" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -1350,14 +1367,14 @@ TcpServerCloseProc(callbackData) */ int -Tcl_SocketObjCmd(notUsed, interp, objc, objv) - ClientData notUsed; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_SocketObjCmd( + ClientData notUsed, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { static CONST char *socketOptions[] = { - "-async", "-myaddr", "-myport","-server", (char *) NULL + "-async", "-myaddr", "-myport","-server", NULL }; enum socketOptions { SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER @@ -1382,16 +1399,15 @@ Tcl_SocketObjCmd(notUsed, interp, objc, objv) if (arg[0] != '-') { break; } - if (Tcl_GetIndexFromObj(interp, objv[a], socketOptions, - "option", TCL_EXACT, &optionIndex) != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, objv[a], socketOptions, "option", + TCL_EXACT, &optionIndex) != TCL_OK) { return TCL_ERROR; } switch ((enum socketOptions) optionIndex) { case SKT_ASYNC: if (server == 1) { Tcl_AppendResult(interp, - "cannot set -async option for server sockets", - (char *) NULL); + "cannot set -async option for server sockets", NULL); return TCL_ERROR; } async = 1; @@ -1400,7 +1416,7 @@ Tcl_SocketObjCmd(notUsed, interp, objc, objv) a++; if (a >= objc) { Tcl_AppendResult(interp, - "no argument given for -myaddr option", (char *) NULL); + "no argument given for -myaddr option", NULL); return TCL_ERROR; } myaddr = Tcl_GetString(objv[a]); @@ -1411,7 +1427,7 @@ Tcl_SocketObjCmd(notUsed, interp, objc, objv) a++; if (a >= objc) { Tcl_AppendResult(interp, - "no argument given for -myport option", (char *) NULL); + "no argument given for -myport option", NULL); return TCL_ERROR; } myPortName = Tcl_GetString(objv[a]); @@ -1423,15 +1439,14 @@ Tcl_SocketObjCmd(notUsed, interp, objc, objv) case SKT_SERVER: if (async == 1) { Tcl_AppendResult(interp, - "cannot set -async option for server sockets", - (char *) NULL); + "cannot set -async option for server sockets", NULL); return TCL_ERROR; } server = 1; a++; if (a >= objc) { Tcl_AppendResult(interp, - "no argument given for -server option", (char *) NULL); + "no argument given for -server option", NULL); return TCL_ERROR; } script = Tcl_GetString(objv[a]); @@ -1443,7 +1458,7 @@ Tcl_SocketObjCmd(notUsed, interp, objc, objv) if (server) { host = myaddr; /* NULL implies INADDR_ANY */ if (myport != 0) { - Tcl_AppendResult(interp, "Option -myport is not valid for servers", + Tcl_AppendResult(interp, "option -myport is not valid for servers", NULL); return TCL_ERROR; } @@ -1512,7 +1527,7 @@ Tcl_SocketObjCmd(notUsed, interp, objc, objv) } } Tcl_RegisterChannel(interp, chan); - Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL); + Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL); return TCL_OK; } @@ -1522,7 +1537,7 @@ Tcl_SocketObjCmd(notUsed, interp, objc, objv) * * Tcl_FcopyObjCmd -- * - * This procedure is invoked to process the "fcopy" Tcl command. See the + * This function is invoked to process the "fcopy" Tcl command. See the * user documentation for details on what it does. * * Results: @@ -1536,11 +1551,11 @@ Tcl_SocketObjCmd(notUsed, interp, objc, objv) */ int -Tcl_FcopyObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_FcopyObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { Tcl_Channel inChan, outChan; char *arg; @@ -1568,7 +1583,7 @@ Tcl_FcopyObjCmd(dummy, interp, objc, objv) } if ((mode & TCL_READABLE) == 0) { Tcl_AppendResult(interp, "channel \"", arg, - "\" wasn't opened for reading", (char *) NULL); + "\" wasn't opened for reading", NULL); return TCL_ERROR; } arg = Tcl_GetString(objv[2]); @@ -1578,7 +1593,7 @@ Tcl_FcopyObjCmd(dummy, interp, objc, objv) } if ((mode & TCL_WRITABLE) == 0) { Tcl_AppendResult(interp, "channel \"", arg, - "\" wasn't opened for writing", (char *) NULL); + "\" wasn't opened for writing", NULL); return TCL_ERROR; } @@ -1609,7 +1624,7 @@ Tcl_FcopyObjCmd(dummy, interp, objc, objv) * * Tcl_ChanTruncateObjCmd -- * - * This procedure is invoked to process the "chan truncate" Tcl command. + * This function is invoked to process the "chan truncate" Tcl command. * See the user documentation for details on what it does. * * Results: @@ -1622,11 +1637,11 @@ Tcl_FcopyObjCmd(dummy, interp, objc, objv) */ int -TclChanTruncateObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +TclChanTruncateObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { Tcl_Channel chan; int mode; @@ -1672,7 +1687,7 @@ TclChanTruncateObjCmd(dummy, interp, objc, objv) if (Tcl_TruncateChannel(chan, length) != TCL_OK) { Tcl_AppendResult(interp, "error during truncate on \"", chanName, - "\": ", Tcl_PosixError(interp), (char *) NULL); + "\": ", Tcl_PosixError(interp), NULL); return TCL_ERROR; } diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c index 48419da..c708bb1 100644 --- a/generic/tclIOGT.c +++ b/generic/tclIOGT.c @@ -1,75 +1,67 @@ /* * tclIOGT.c -- * - * Implements a generic transformation exposing the underlying API - * at the script level. Contributed by Andreas Kupries. + * Implements a generic transformation exposing the underlying API at the + * script level. Contributed by Andreas Kupries. * * Copyright (c) 2000 Ajuba Solutions * Copyright (c) 1999-2000 Andreas Kupries (a.kupries@westend.com) * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * CVS: $Id: tclIOGT.c,v 1.13 2005/07/17 21:17:41 dkf Exp $ + * CVS: $Id: tclIOGT.c,v 1.14 2005/11/01 15:30:52 dkf Exp $ */ #include "tclInt.h" #include "tclIO.h" /* - * Forward declarations of internal procedures. First the driver procedures - * of the transformation. + * Forward declarations of internal procedures. First the driver procedures of + * the transformation. */ -static int TransformBlockModeProc _ANSI_ARGS_(( - ClientData instanceData, int mode)); -static int TransformCloseProc _ANSI_ARGS_(( - ClientData instanceData, Tcl_Interp* interp)); -static int TransformInputProc _ANSI_ARGS_(( - ClientData instanceData, char *buf, int toRead, - int *errorCodePtr)); -static int TransformOutputProc _ANSI_ARGS_(( - ClientData instanceData, CONST char *buf, - int toWrite, int *errorCodePtr)); -static int TransformSeekProc _ANSI_ARGS_(( - ClientData instanceData, long offset, int mode, - int *errorCodePtr)); -static int TransformSetOptionProc _ANSI_ARGS_(( - ClientData instanceData, Tcl_Interp *interp, - CONST char *optionName, CONST char *value)); -static int TransformGetOptionProc _ANSI_ARGS_(( - ClientData instanceData, Tcl_Interp *interp, - CONST char *optionName, Tcl_DString *dsPtr)); -static void TransformWatchProc _ANSI_ARGS_(( - ClientData instanceData, int mask)); -static int TransformGetFileHandleProc _ANSI_ARGS_(( - ClientData instanceData, int direction, - ClientData *handlePtr)); -static int TransformNotifyProc _ANSI_ARGS_(( - ClientData instanceData, int mask)); -static Tcl_WideInt TransformWideSeekProc _ANSI_ARGS_(( - ClientData instanceData, Tcl_WideInt offset, - int mode, int *errorCodePtr)); +static int TransformBlockModeProc(ClientData instanceData, + int mode); +static int TransformCloseProc(ClientData instanceData, + Tcl_Interp* interp); +static int TransformInputProc(ClientData instanceData, char *buf, + int toRead, int *errorCodePtr); +static int TransformOutputProc(ClientData instanceData, + CONST char *buf, int toWrite, int *errorCodePtr); +static int TransformSeekProc(ClientData instanceData, long offset, + int mode, int *errorCodePtr); +static int TransformSetOptionProc(ClientData instanceData, + Tcl_Interp *interp, CONST char *optionName, + CONST char *value); +static int TransformGetOptionProc(ClientData instanceData, + Tcl_Interp *interp, CONST char *optionName, + Tcl_DString *dsPtr); +static void TransformWatchProc(ClientData instanceData, int mask); +static int TransformGetFileHandleProc(ClientData instanceData, + int direction, ClientData *handlePtr); +static int TransformNotifyProc(ClientData instanceData, int mask); +static Tcl_WideInt TransformWideSeekProc(ClientData instanceData, + Tcl_WideInt offset, int mode, int *errorCodePtr); /* - * Forward declarations of internal procedures. Secondly the procedures for + * Forward declarations of internal procedures. Secondly the procedures for * handling and generating fileeevents. */ -static void TransformChannelHandlerTimer _ANSI_ARGS_(( - ClientData clientData)); +static void TransformChannelHandlerTimer(ClientData clientData); /* - * Forward declarations of internal procedures. Third, helper procedures + * Forward declarations of internal procedures. Third, helper procedures * encapsulating essential tasks. */ typedef struct TransformChannelData TransformChannelData; -static int ExecuteCallback _ANSI_ARGS_(( - TransformChannelData *ctrl, Tcl_Interp *interp, - unsigned char *op, unsigned char *buf, int bufLen, - int transmit, int preserve)); +static int ExecuteCallback(TransformChannelData *ctrl, + Tcl_Interp *interp, unsigned char *op, + unsigned char *buf, int bufLen, int transmit, + int preserve); /* * Action codes to give to 'ExecuteCallback' (argument 'transmit') confering @@ -113,13 +105,13 @@ static int ExecuteCallback _ANSI_ARGS_(( typedef struct ResultBuffer ResultBuffer; -static void ResultClear _ANSI_ARGS_((ResultBuffer *r)); -static void ResultInit _ANSI_ARGS_((ResultBuffer *r)); -static int ResultLength _ANSI_ARGS_((ResultBuffer *r)); -static int ResultCopy _ANSI_ARGS_((ResultBuffer *r, - unsigned char *buf, int toRead)); -static void ResultAdd _ANSI_ARGS_((ResultBuffer *r, - unsigned char *buf, int toWrite)); +static void ResultClear(ResultBuffer *r); +static void ResultInit(ResultBuffer *r); +static int ResultLength(ResultBuffer *r); +static int ResultCopy(ResultBuffer *r, unsigned char *buf, + int toRead); +static void ResultAdd(ResultBuffer *r, unsigned char *buf, + int toWrite); /* * This structure describes the channel type structure for Tcl based @@ -180,7 +172,6 @@ struct ResultBuffer { */ #define UCHARP(x) ((unsigned char *) (x)) -#define NO_INTERP ((Tcl_Interp *) NULL) /* * Definition of a structure used by all transformations generated here to @@ -226,7 +217,7 @@ struct TransformChannelData { * * TclChannelTransform -- * - * Implements the Tcl "testchannel transform" debugging command. This is + * Implements the Tcl "testchannel transform" debugging command. This is * part of the testing environment. This sets up a tcl script (cmdObjPtr) * to be used as a transform on the channel. * @@ -241,10 +232,10 @@ struct TransformChannelData { /* ARGSUSED */ int -TclChannelTransform(interp, chan, cmdObjPtr) - Tcl_Interp *interp; /* Interpreter for result. */ - Tcl_Channel chan; /* Channel to transform. */ - Tcl_Obj *cmdObjPtr; /* Script to use for transform. */ +TclChannelTransform( + Tcl_Interp *interp, /* Interpreter for result. */ + Tcl_Channel chan, /* Channel to transform. */ + Tcl_Obj *cmdObjPtr) /* Script to use for transform. */ { Channel *chanPtr; /* The actual channel. */ ChannelState *statePtr; /* state info for channel */ @@ -298,7 +289,7 @@ TclChannelTransform(interp, chan, cmdObjPtr) (ClientData) dataPtr, mode, chan); if (dataPtr->self == (Tcl_Channel) NULL) { Tcl_AppendResult(interp, "\nfailed to stack channel \"", - Tcl_GetChannelName(chan), "\"", (char *) NULL); + Tcl_GetChannelName(chan), "\"", NULL); Tcl_DecrRefCount(dataPtr->command); ResultClear(&dataPtr->result); @@ -311,7 +302,7 @@ TclChannelTransform(interp, chan, cmdObjPtr) */ if (dataPtr->mode & TCL_WRITABLE) { - res = ExecuteCallback(dataPtr, NO_INTERP, A_CREATE_WRITE, NULL, 0, + res = ExecuteCallback(dataPtr, NULL, A_CREATE_WRITE, NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE); if (res != TCL_OK) { @@ -321,11 +312,11 @@ TclChannelTransform(interp, chan, cmdObjPtr) } if (dataPtr->mode & TCL_READABLE) { - res = ExecuteCallback(dataPtr, NO_INTERP, A_CREATE_READ, NULL, 0, + res = ExecuteCallback(dataPtr, NULL, A_CREATE_READ, NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE); if (res != TCL_OK) { - ExecuteCallback(dataPtr, NO_INTERP, A_DELETE_WRITE, NULL, 0, + ExecuteCallback(dataPtr, NULL, A_DELETE_WRITE, NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE); Tcl_UnstackChannel(interp, chan); @@ -354,19 +345,19 @@ TclChannelTransform(interp, chan, cmdObjPtr) */ static int -ExecuteCallback(dataPtr, interp, op, buf, bufLen, transmit, preserve) - TransformChannelData *dataPtr; /* Transformation with the callback */ - Tcl_Interp *interp; /* Current interpreter, possibly - * NULL. */ - unsigned char *op; /* Operation invoking the callback */ - unsigned char *buf; /* Buffer to give to the script. */ - int bufLen; /* And its length */ - int transmit; /* Flag, determines whether the result - * of the callback is sent to the - * underlying channel or not. */ - int preserve; /* Flag. If true the procedure will - * preserver the result state of all - * accessed interpreters. */ +ExecuteCallback( + TransformChannelData *dataPtr, + /* Transformation with the callback */ + Tcl_Interp *interp, /* Current interpreter, possibly NULL. */ + unsigned char *op, /* Operation invoking the callback */ + unsigned char *buf, /* Buffer to give to the script. */ + int bufLen, /* And its length */ + int transmit, /* Flag, determines whether the result of the + * callback is sent to the underlying channel + * or not. */ + int preserve) /* Flag. If true the procedure will preserver + * the result state of all accessed + * interpreters. */ { /* * Step 1, create the complete command to execute. Do this by appending @@ -376,35 +367,20 @@ ExecuteCallback(dataPtr, interp, op, buf, bufLen, transmit, preserve) * arguments. Feather's curried commands would come in handy here. */ - Tcl_Obj *resObj; /* See below, switch (transmit) */ + Tcl_Obj *resObj; /* See below, switch (transmit) */ int resLen; unsigned char *resBuf; Tcl_InterpState state = NULL; int res = TCL_OK; Tcl_Obj *command = Tcl_DuplicateObj(dataPtr->command); - Tcl_Obj *temp; if (preserve) { state = Tcl_SaveInterpState(dataPtr->interp, res); } - if (command == (Tcl_Obj*) NULL) { - /* Memory allocation problem */ - res = TCL_ERROR; - goto cleanup; - } - Tcl_IncrRefCount(command); - - temp = Tcl_NewStringObj((char*) op, -1); - - if (temp == (Tcl_Obj*) NULL) { - /* Memory allocation problem */ - res = TCL_ERROR; - goto cleanup; - } - - res = Tcl_ListObjAppendElement(dataPtr->interp, command, temp); + res = Tcl_ListObjAppendElement(dataPtr->interp, command, + Tcl_NewStringObj((char*) op, -1)); if (res != TCL_OK) { goto cleanup; } @@ -414,15 +390,8 @@ ExecuteCallback(dataPtr, interp, op, buf, bufLen, transmit, preserve) * through as UTF while at the tcl level. */ - temp = Tcl_NewByteArrayObj(buf, bufLen); - - if (temp == (Tcl_Obj*) NULL) { - /* Memory allocation problem */ - res = TCL_ERROR; - goto cleanup; - } - - res = Tcl_ListObjAppendElement(dataPtr->interp, command, temp); + res = Tcl_ListObjAppendElement(dataPtr->interp, command, + Tcl_NewByteArrayObj(buf, bufLen)); if (res != TCL_OK) { goto cleanup; } @@ -437,9 +406,9 @@ ExecuteCallback(dataPtr, interp, op, buf, bufLen, transmit, preserve) res = Tcl_GlobalEvalObj(dataPtr->interp, command); Tcl_DecrRefCount(command); - command = (Tcl_Obj*) NULL; + command = NULL; - if ((res != TCL_OK) && (interp != NO_INTERP) && + if ((res != TCL_OK) && (interp != NULL) && (dataPtr->interp != interp) && !preserve) { Tcl_SetObjResult(interp, Tcl_GetObjResult(dataPtr->interp)); return res; @@ -475,7 +444,10 @@ ExecuteCallback(dataPtr, interp, op, buf, bufLen, transmit, preserve) break; case TRANSMIT_NUM: - /* Interpret result as integer number */ + /* + * Interpret result as integer number. + */ + resObj = Tcl_GetObjResult(dataPtr->interp); Tcl_GetIntFromObj(dataPtr->interp, resObj, &dataPtr->maxRead); break; @@ -494,7 +466,7 @@ ExecuteCallback(dataPtr, interp, op, buf, bufLen, transmit, preserve) (void) Tcl_RestoreInterpState(dataPtr->interp, state); } - if (command != (Tcl_Obj*) NULL) { + if (command != NULL) { Tcl_DecrRefCount(command); } @@ -519,9 +491,9 @@ ExecuteCallback(dataPtr, interp, op, buf, bufLen, transmit, preserve) */ static int -TransformBlockModeProc(instanceData, mode) - ClientData instanceData; /* State of transformation */ - int mode; /* New blocking mode */ +TransformBlockModeProc( + ClientData instanceData, /* State of transformation */ + int mode) /* New blocking mode */ { TransformChannelData *dataPtr = (TransformChannelData *) instanceData; @@ -551,9 +523,9 @@ TransformBlockModeProc(instanceData, mode) */ static int -TransformCloseProc(instanceData, interp) - ClientData instanceData; - Tcl_Interp *interp; +TransformCloseProc( + ClientData instanceData, + Tcl_Interp *interp) { TransformChannelData *dataPtr = (TransformChannelData *) instanceData; @@ -632,11 +604,11 @@ TransformCloseProc(instanceData, interp) */ static int -TransformInputProc(instanceData, buf, toRead, errorCodePtr) - ClientData instanceData; - char *buf; - int toRead; - int *errorCodePtr; +TransformInputProc( + ClientData instanceData, + char *buf, + int toRead, + int *errorCodePtr) { TransformChannelData* dataPtr = (TransformChannelData *) instanceData; int gotBytes, read, res, copied; @@ -668,7 +640,7 @@ TransformInputProc(instanceData, buf, toRead, errorCodePtr) if (toRead == 0) { /* - * The request was completely satisfied from our buffers. We can + * The request was completely satisfied from our buffers. We can * break out of the loop and return to the caller. */ return gotBytes; @@ -686,7 +658,7 @@ TransformInputProc(instanceData, buf, toRead, errorCodePtr) * matching. */ - ExecuteCallback(dataPtr, NO_INTERP, A_QUERY_MAXREAD, NULL, 0, + ExecuteCallback(dataPtr, NULL, A_QUERY_MAXREAD, NULL, 0, TRANSMIT_NUM /* -> maxRead */, 1); if (dataPtr->maxRead >= 0) { @@ -703,7 +675,7 @@ TransformInputProc(instanceData, buf, toRead, errorCodePtr) if (read < 0) { /* - * Report errors to caller. EAGAIN is a special situation. If we + * Report errors to caller. EAGAIN is a special situation. If we * had some data before we report that instead of the request to * re-try. */ @@ -713,7 +685,7 @@ TransformInputProc(instanceData, buf, toRead, errorCodePtr) } *errorCodePtr = Tcl_GetErrno(); - return -1; + return -1; } if (read == 0) { @@ -744,7 +716,7 @@ TransformInputProc(instanceData, buf, toRead, errorCodePtr) dataPtr->readIsFlushed = 1; - ExecuteCallback(dataPtr, NO_INTERP, A_FLUSH_READ, NULL, 0, + ExecuteCallback(dataPtr, NULL, A_FLUSH_READ, NULL, 0, TRANSMIT_IBUF, P_PRESERVE); if (ResultLength(&dataPtr->result) == 0) { @@ -761,7 +733,7 @@ TransformInputProc(instanceData, buf, toRead, errorCodePtr) * (dataPtr->result) */ - res = ExecuteCallback(dataPtr, NO_INTERP, A_READ, UCHARP(buf), read, + res = ExecuteCallback(dataPtr, NULL, A_READ, UCHARP(buf), read, TRANSMIT_IBUF, P_PRESERVE); if (res != TCL_OK) { @@ -790,11 +762,11 @@ TransformInputProc(instanceData, buf, toRead, errorCodePtr) */ static int -TransformOutputProc(instanceData, buf, toWrite, errorCodePtr) - ClientData instanceData; - CONST char *buf; - int toWrite; - int *errorCodePtr; +TransformOutputProc( + ClientData instanceData, + CONST char *buf, + int toWrite, + int *errorCodePtr) { TransformChannelData* dataPtr = (TransformChannelData*) instanceData; int res; @@ -808,7 +780,7 @@ TransformOutputProc(instanceData, buf, toWrite, errorCodePtr) return 0; } - res = ExecuteCallback(dataPtr, NO_INTERP, A_WRITE, UCHARP(buf), toWrite, + res = ExecuteCallback(dataPtr, NULL, A_WRITE, UCHARP(buf), toWrite, TRANSMIT_DOWN, P_NO_PRESERVE); if (res != TCL_OK) { @@ -829,7 +801,7 @@ TransformOutputProc(instanceData, buf, toWrite, errorCodePtr) * * Side effects: * Moves the location at which the channel will be accessed in future - * operations. Flushes all transformation buffers, then forwards it to + * operations. Flushes all transformation buffers, then forwards it to * the underlying channel. * * Result: @@ -840,11 +812,11 @@ TransformOutputProc(instanceData, buf, toWrite, errorCodePtr) */ static int -TransformSeekProc(instanceData, offset, mode, errorCodePtr) - ClientData instanceData; /* The channel to manipulate */ - long offset; /* Size of movement. */ - int mode; /* How to move */ - int *errorCodePtr; /* Location of error flag. */ +TransformSeekProc( + ClientData instanceData, /* The channel to manipulate */ + long offset, /* Size of movement. */ + int mode, /* How to move */ + int *errorCodePtr) /* Location of error flag. */ { TransformChannelData *dataPtr = (TransformChannelData *) instanceData; Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self); @@ -868,12 +840,12 @@ TransformSeekProc(instanceData, offset, mode, errorCodePtr) */ if (dataPtr->mode & TCL_WRITABLE) { - ExecuteCallback(dataPtr, NO_INTERP, A_FLUSH_WRITE, NULL, 0, + ExecuteCallback(dataPtr, NULL, A_FLUSH_WRITE, NULL, 0, TRANSMIT_DOWN, P_NO_PRESERVE); } if (dataPtr->mode & TCL_READABLE) { - ExecuteCallback(dataPtr, NO_INTERP, A_CLEAR_READ, NULL, 0, + ExecuteCallback(dataPtr, NULL, A_CLEAR_READ, NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE); ResultClear(&dataPtr->result); dataPtr->readIsFlushed = 0; @@ -893,7 +865,7 @@ TransformSeekProc(instanceData, offset, mode, errorCodePtr) * * Side effects: * Moves the location at which the channel will be accessed in future - * operations. Flushes all transformation buffers, then forwards it to + * operations. Flushes all transformation buffers, then forwards it to * the underlying channel. * * Result: @@ -904,11 +876,11 @@ TransformSeekProc(instanceData, offset, mode, errorCodePtr) */ static Tcl_WideInt -TransformWideSeekProc(instanceData, offset, mode, errorCodePtr) - ClientData instanceData; /* The channel to manipulate */ - Tcl_WideInt offset; /* Size of movement. */ - int mode; /* How to move */ - int *errorCodePtr; /* Location of error flag. */ +TransformWideSeekProc( + ClientData instanceData, /* The channel to manipulate */ + Tcl_WideInt offset, /* Size of movement. */ + int mode, /* How to move */ + int *errorCodePtr) /* Location of error flag. */ { TransformChannelData * dataPtr = (TransformChannelData *) instanceData; Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self); @@ -940,12 +912,12 @@ TransformWideSeekProc(instanceData, offset, mode, errorCodePtr) */ if (dataPtr->mode & TCL_WRITABLE) { - ExecuteCallback(dataPtr, NO_INTERP, A_FLUSH_WRITE, NULL, 0, + ExecuteCallback(dataPtr, NULL, A_FLUSH_WRITE, NULL, 0, TRANSMIT_DOWN, P_NO_PRESERVE); } if (dataPtr->mode & TCL_READABLE) { - ExecuteCallback(dataPtr, NO_INTERP, A_CLEAR_READ, NULL, 0, + ExecuteCallback(dataPtr, NULL, A_CLEAR_READ, NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE); ResultClear(&dataPtr->result); dataPtr->readIsFlushed = 0; @@ -963,7 +935,7 @@ TransformWideSeekProc(instanceData, offset, mode, errorCodePtr) * We're transferring to narrow seeks at this point; this is a bit complex * because we have to check whether the seek is possible first (i.e. * whether we are losing information in truncating the bits of the - * offset.) Luckily, there's a defined error for what happens when trying + * offset). Luckily, there's a defined error for what happens when trying * to go out of the representable range. */ @@ -995,11 +967,11 @@ TransformWideSeekProc(instanceData, offset, mode, errorCodePtr) */ static int -TransformSetOptionProc(instanceData, interp, optionName, value) - ClientData instanceData; - Tcl_Interp *interp; - CONST char *optionName; - CONST char *value; +TransformSetOptionProc( + ClientData instanceData, + Tcl_Interp *interp, + CONST char *optionName, + CONST char *value) { TransformChannelData* dataPtr = (TransformChannelData*) instanceData; Tcl_Channel downChan = Tcl_GetStackedChannel(dataPtr->self); @@ -1032,11 +1004,11 @@ TransformSetOptionProc(instanceData, interp, optionName, value) */ static int -TransformGetOptionProc(instanceData, interp, optionName, dsPtr) - ClientData instanceData; - Tcl_Interp *interp; - CONST char *optionName; - Tcl_DString *dsPtr; +TransformGetOptionProc( + ClientData instanceData, + Tcl_Interp *interp, + CONST char *optionName, + Tcl_DString *dsPtr) { TransformChannelData* dataPtr = (TransformChannelData*) instanceData; Tcl_Channel downChan = Tcl_GetStackedChannel(dataPtr->self); @@ -1046,7 +1018,7 @@ TransformGetOptionProc(instanceData, interp, optionName, dsPtr) if (getOptionProc != NULL) { return (*getOptionProc)(Tcl_GetChannelInstanceData(downChan), interp, optionName, dsPtr); - } else if (optionName == (CONST char*) NULL) { + } else if (optionName == NULL) { /* * Request is query for all options, this is ok. */ @@ -1080,9 +1052,9 @@ TransformGetOptionProc(instanceData, interp, optionName, dsPtr) /* ARGSUSED */ static void -TransformWatchProc(instanceData, mask) - ClientData instanceData; /* Channel to watch */ - int mask; /* Events of interest */ +TransformWatchProc( + ClientData instanceData, /* Channel to watch */ + int mask) /* Events of interest */ { /* * The caller expressed interest in events occuring for this channel. We @@ -1097,7 +1069,7 @@ TransformWatchProc(instanceData, mask) /* * No channel handlers any more. We will be notified automatically about * events on the channel below via a call to our 'TransformNotifyProc'. - * But we have to pass the interest down now. We are allowed to add + * But we have to pass the interest down now. We are allowed to add * additional 'interest' to the mask if we want to. But this * transformation has no such interest. It just passes the request down, * unchanged. @@ -1149,19 +1121,19 @@ TransformWatchProc(instanceData, mask) * None. * * Result: - * The appropriate Tcl_File or NULL if not present. + * The appropriate Tcl_File or NULL if not present. * *---------------------------------------------------------------------- */ static int -TransformGetFileHandleProc(instanceData, direction, handlePtr) - ClientData instanceData; /* Channel to query */ - int direction; /* Direction of interest */ - ClientData *handlePtr; /* Place to store the handle into */ +TransformGetFileHandleProc( + ClientData instanceData, /* Channel to query */ + int direction, /* Direction of interest */ + ClientData *handlePtr) /* Place to store the handle into */ { /* - * Return the handle belonging to parent channel. IOW, pass the request + * Return the handle belonging to parent channel. IOW, pass the request * down and the result up. */ @@ -1189,15 +1161,15 @@ TransformGetFileHandleProc(instanceData, direction, handlePtr) */ static int -TransformNotifyProc(clientData, mask) - ClientData clientData; /* The state of the notified transformation */ - int mask; /* The mask of occuring events */ +TransformNotifyProc( + ClientData clientData, /* The state of the notified transformation */ + int mask) /* The mask of occuring events */ { TransformChannelData *dataPtr = (TransformChannelData *) clientData; /* - * An event occured in the underlying channel. This transformation - * doesn't process such events thus returns the incoming mask unchanged. + * An event occured in the underlying channel. This transformation doesn't + * process such events thus returns the incoming mask unchanged. */ if (dataPtr->timer != (Tcl_TimerToken) NULL) { @@ -1234,8 +1206,8 @@ TransformNotifyProc(clientData, mask) */ static void -TransformChannelHandlerTimer(clientData) - ClientData clientData; /* Transformation to query */ +TransformChannelHandlerTimer( + ClientData clientData) /* Transformation to query */ { TransformChannelData *dataPtr = (TransformChannelData *) clientData; @@ -1272,14 +1244,14 @@ TransformChannelHandlerTimer(clientData) */ static void -ResultClear(r) - ResultBuffer *r; /* Reference to the buffer to clear out. */ +ResultClear( + ResultBuffer *r) /* Reference to the buffer to clear out. */ { r->used = 0; if (r->allocated) { ckfree((char *) r->buf); - r->buf = UCHARP(NULL); + r->buf = NULL; r->allocated = 0; } } @@ -1302,12 +1274,12 @@ ResultClear(r) */ static void -ResultInit(r) - ResultBuffer *r; /* Reference to the structure to initialize */ +ResultInit( + ResultBuffer *r) /* Reference to the structure to initialize */ { r->used = 0; r->allocated = 0; - r->buf = UCHARP(NULL); + r->buf = NULL; } /* @@ -1327,8 +1299,8 @@ ResultInit(r) */ static int -ResultLength(r) - ResultBuffer *r; /* The structure to query */ +ResultLength( + ResultBuffer *r) /* The structure to query */ { return r->used; } @@ -1352,10 +1324,10 @@ ResultLength(r) */ static int -ResultCopy(r, buf, toRead) - ResultBuffer *r; /* The buffer to read from. */ - unsigned char *buf; /* The buffer to copy into. */ - int toRead; /* Number of requested bytes. */ +ResultCopy( + ResultBuffer *r, /* The buffer to read from. */ + unsigned char *buf, /* The buffer to copy into. */ + int toRead) /* Number of requested bytes. */ { if (r->used == 0) { /* @@ -1377,7 +1349,7 @@ ResultCopy(r, buf, toRead) if (r->used > toRead) { /* - * The internal buffer contains more than requested. Copy the + * The internal buffer contains more than requested. Copy the * requested subset to the caller, and shift the remaining bytes down. */ @@ -1395,7 +1367,7 @@ ResultCopy(r, buf, toRead) */ memcpy((VOID *) buf, (VOID *) r->buf, (size_t) r->used); - toRead = r->used; + toRead = r->used; r->used = 0; return toRead; } @@ -1417,10 +1389,10 @@ ResultCopy(r, buf, toRead) */ static void -ResultAdd(r, buf, toWrite) - ResultBuffer *r; /* The buffer to extend */ - unsigned char *buf; /* The buffer to read from */ - int toWrite; /* The number of bytes in 'buf' */ +ResultAdd( + ResultBuffer *r, /* The buffer to extend */ + unsigned char *buf, /* The buffer to read from */ + int toWrite) /* The number of bytes in 'buf' */ { if ((r->used + toWrite) > r->allocated) { /* @@ -1437,7 +1409,10 @@ ResultAdd(r, buf, toWrite) } } - /* now copy data */ + /* + * Now we may copy the data. + */ + memcpy(r->buf + r->used, buf, (size_t) toWrite); r->used += toWrite; } diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 124da3a..78cc0ff 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -5,7 +5,7 @@ * code, which supports a pluggable filesystem architecture allowing both * platform specific filesystems and 'virtual filesystems'. All * filesystem access should go through the functions defined in this - * file. Most of this code was contributed by Vince Darley. + * file. Most of this code was contributed by Vince Darley. * * Parts of this file are based on code contributed by Karl Lehenbauer, * Mark Diekhans and Peter da Silva. @@ -17,7 +17,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIOUtil.c,v 1.123 2005/09/14 17:13:18 dgp Exp $ + * RCS: @(#) $Id: tclIOUtil.c,v 1.124 2005/11/01 15:30:52 dkf Exp $ */ #include "tclInt.h" @@ -27,29 +27,26 @@ #include "tclFileSystem.h" /* - * Prototypes for procedures defined later in this file. + * Prototypes for functions defined later in this file. */ -static FilesystemRecord * FsGetFirstFilesystem _ANSI_ARGS_((void)); -static void FsThrExitProc _ANSI_ARGS_((ClientData cd)); -static Tcl_Obj* FsListMounts _ANSI_ARGS_((Tcl_Obj *pathPtr, - CONST char *pattern)); -static void FsAddMountsToGlobResult _ANSI_ARGS_(( - Tcl_Obj *resultPtr, Tcl_Obj *pathPtr, - CONST char *pattern, - Tcl_GlobTypeData *types)); -static void FsUpdateCwd _ANSI_ARGS_((Tcl_Obj *cwdObj, - ClientData clientData)); +static FilesystemRecord*FsGetFirstFilesystem(void); +static void FsThrExitProc(ClientData cd); +static Tcl_Obj * FsListMounts(Tcl_Obj *pathPtr, CONST char *pattern); +static void FsAddMountsToGlobResult(Tcl_Obj *resultPtr, + Tcl_Obj *pathPtr, CONST char *pattern, + Tcl_GlobTypeData *types); +static void FsUpdateCwd(Tcl_Obj *cwdObj, ClientData clientData); #ifdef TCL_THREADS -static void FsRecacheFilesystemList(void); +static void FsRecacheFilesystemList(void); #endif /* - * These form part of the native filesystem support. They are needed here + * These form part of the native filesystem support. They are needed here * because we have a few native filesystem functions (which are the same for - * win/unix) in this file. There is no need to place them in tclInt.h, - * because they are not (and should not be) used anywhere else. + * win/unix) in this file. There is no need to place them in tclInt.h, because + * they are not (and should not be) used anywhere else. */ extern CONST char * tclpFileAttrStrings[]; @@ -59,12 +56,13 @@ extern CONST TclFileAttrProcs tclpFileAttrProcs[]; * The following functions are obsolete string based APIs, and should be * removed in a future release (Tcl 9 would be a good time). */ + /* Obsolete */ int -Tcl_Stat(path, oldStyleBuf) - CONST char *path; /* Path of file to stat (in current CP). */ - struct stat *oldStyleBuf; /* Filled with results of stat call. */ +Tcl_Stat( + CONST char *path, /* Path of file to stat (in current CP). */ + struct stat *oldStyleBuf) /* Filled with results of stat call. */ { int ret; Tcl_StatBuf buf; @@ -98,7 +96,7 @@ Tcl_Stat(path, oldStyleBuf) # ifdef EOVERFLOW errno = EOVERFLOW; # else -# error "What status should be returned for file size out of range?" +# error "What status should be returned for file size out of range?" # endif #endif return -1; @@ -111,7 +109,7 @@ Tcl_Stat(path, oldStyleBuf) /* * Copy across all supported fields, with possible type coercions on * those fields that change between the normal and lf64 versions of - * the stat structure (on Solaris at least.) This is slow when the + * the stat structure (on Solaris at least). This is slow when the * structure sizes coincide, but that's what you get for using an * obsolete interface. */ @@ -137,9 +135,9 @@ Tcl_Stat(path, oldStyleBuf) /* Obsolete */ int -Tcl_Access(path, mode) - CONST char *path; /* Path of file to access (in current CP). */ - int mode; /* Permission setting. */ +Tcl_Access( + CONST char *path, /* Path of file to access (in current CP). */ + int mode) /* Permission setting. */ { int ret; Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1); @@ -153,13 +151,13 @@ Tcl_Access(path, mode) /* Obsolete */ Tcl_Channel -Tcl_OpenFileChannel(interp, path, modeString, permissions) - Tcl_Interp *interp; /* Interpreter for error reporting; can be +Tcl_OpenFileChannel( + Tcl_Interp *interp, /* Interpreter for error reporting; can be * NULL. */ - CONST char *path; /* Name of file to open. */ - CONST char *modeString; /* A list of POSIX open modes or a string such + CONST char *path, /* Name of file to open. */ + CONST char *modeString, /* A list of POSIX open modes or a string such * as "rw". */ - int permissions; /* If the open involves creating a file, with + int permissions) /* If the open involves creating a file, with * what modes to create it? */ { Tcl_Channel ret; @@ -174,8 +172,8 @@ Tcl_OpenFileChannel(interp, path, modeString, permissions) /* Obsolete */ int -Tcl_Chdir(dirName) - CONST char *dirName; +Tcl_Chdir( + CONST char *dirName) { int ret; Tcl_Obj *pathPtr = Tcl_NewStringObj(dirName,-1); @@ -187,9 +185,9 @@ Tcl_Chdir(dirName) /* Obsolete */ char * -Tcl_GetCwd(interp, cwdPtr) - Tcl_Interp *interp; - Tcl_DString *cwdPtr; +Tcl_GetCwd( + Tcl_Interp *interp, + Tcl_DString *cwdPtr) { Tcl_Obj *cwd; cwd = Tcl_FSGetCwd(interp); @@ -205,9 +203,9 @@ Tcl_GetCwd(interp, cwdPtr) /* Obsolete */ int -Tcl_EvalFile(interp, fileName) - Tcl_Interp *interp; /* Interpreter in which to process file. */ - CONST char *fileName; /* Name of file to process. Tilde-substitution +Tcl_EvalFile( + Tcl_Interp *interp, /* Interpreter in which to process file. */ + CONST char *fileName) /* Name of file to process. Tilde-substitution * will be performed on this name. */ { int ret; @@ -219,11 +217,11 @@ Tcl_EvalFile(interp, fileName) } /* - * The 3 hooks for Stat, Access and OpenFileChannel are obsolete. The - * complete, general hooked filesystem APIs should be used instead. This - * define decides whether to include the obsolete hooks and related code. If - * these are removed, we'll also want to remove them from stubs/tclInt. The - * only known users of these APIs are prowrap and mktclapp. New + * The 3 hooks for Stat, Access and OpenFileChannel are obsolete. The + * complete, general hooked filesystem APIs should be used instead. This + * define decides whether to include the obsolete hooks and related code. If + * these are removed, we'll also want to remove them from stubs/tclInt. The + * only known users of these APIs are prowrap and mktclapp. New * code/extensions should not use them, since they do not provide as full * support as the full filesystem API. * @@ -238,26 +236,27 @@ Tcl_EvalFile(interp, fileName) /* * The following typedef declarations allow for hooking into the chain of * functions maintained for 'Tcl_Stat(...)', 'Tcl_Access(...)' & - * 'Tcl_OpenFileChannel(...)'. Basically for each hookable function a linked + * 'Tcl_OpenFileChannel(...)'. Basically for each hookable function a linked * list is defined. */ typedef struct StatProc { - TclStatProc_ *proc; /* Function to process a 'stat()' call */ - struct StatProc *nextPtr; /* The next 'stat()' function to call */ + TclStatProc_ *proc; /* Function to process a 'stat()' call */ + struct StatProc *nextPtr; /* The next 'stat()' function to call */ } StatProc; typedef struct AccessProc { - TclAccessProc_ *proc; /* Function to process a 'access()' call */ - struct AccessProc *nextPtr; /* The next 'access()' function to call */ + TclAccessProc_ *proc; /* Function to process a 'access()' call */ + struct AccessProc *nextPtr; /* The next 'access()' function to call */ } AccessProc; typedef struct OpenFileChannelProc { - TclOpenFileChannelProc_ *proc; /* Function to process a - * 'Tcl_OpenFileChannel()' call */ + TclOpenFileChannelProc_ *proc; + /* Function to process a + * 'Tcl_OpenFileChannel()' call */ struct OpenFileChannelProc *nextPtr; - /* The next 'Tcl_OpenFileChannel()' - * function to call */ + /* The next 'Tcl_OpenFileChannel()' function + * to call */ } OpenFileChannelProc; /* @@ -282,11 +281,11 @@ TCL_DECLARE_MUTEX(obsoleteFsHookMutex) #endif /* USE_OBSOLETE_FS_HOOKS */ /* - * Declare the native filesystem support. These functions should be - * considered private to Tcl, and should really not be called directly by any - * code other than this file (i.e. neither by Tcl's core nor by extensions). - * Similarly, the old string-based Tclp... native filesystem functions should - * not be called. + * Declare the native filesystem support. These functions should be considered + * private to Tcl, and should really not be called directly by any code other + * than this file (i.e. neither by Tcl's core nor by extensions). Similarly, + * the old string-based Tclp... native filesystem functions should not be + * called. * * The correct API to use now is the Tcl_FS... set of functions, which ensure * correct and complete virtual filesystem support. @@ -298,8 +297,8 @@ TCL_DECLARE_MUTEX(obsoleteFsHookMutex) static Tcl_FSFilesystemSeparatorProc NativeFilesystemSeparator; static Tcl_FSFreeInternalRepProc NativeFreeInternalRep; static Tcl_FSFileAttrStringsProc NativeFileAttrStrings; -static Tcl_FSFileAttrsGetProc NativeFileAttrsGet; -static Tcl_FSFileAttrsSetProc NativeFileAttrsSet; +static Tcl_FSFileAttrsGetProc NativeFileAttrsGet; +static Tcl_FSFileAttrsSetProc NativeFileAttrsSet; /* * The only reason these functions are not static is that they are either @@ -310,29 +309,29 @@ static Tcl_FSFileAttrsSetProc NativeFileAttrsSet; * support into a separate code library, this could actually be enforced). */ -Tcl_FSFilesystemPathTypeProc TclpFilesystemPathType; -Tcl_FSInternalToNormalizedProc TclpNativeToNormalized; -Tcl_FSStatProc TclpObjStat; -Tcl_FSAccessProc TclpObjAccess; -Tcl_FSMatchInDirectoryProc TclpMatchInDirectory; -Tcl_FSChdirProc TclpObjChdir; -Tcl_FSLstatProc TclpObjLstat; -Tcl_FSCopyFileProc TclpObjCopyFile; -Tcl_FSDeleteFileProc TclpObjDeleteFile; -Tcl_FSRenameFileProc TclpObjRenameFile; -Tcl_FSCreateDirectoryProc TclpObjCreateDirectory; -Tcl_FSCopyDirectoryProc TclpObjCopyDirectory; -Tcl_FSRemoveDirectoryProc TclpObjRemoveDirectory; -Tcl_FSUnloadFileProc TclpUnloadFile; -Tcl_FSLinkProc TclpObjLink; -Tcl_FSListVolumesProc TclpObjListVolumes; +Tcl_FSFilesystemPathTypeProc TclpFilesystemPathType; +Tcl_FSInternalToNormalizedProc TclpNativeToNormalized; +Tcl_FSStatProc TclpObjStat; +Tcl_FSAccessProc TclpObjAccess; +Tcl_FSMatchInDirectoryProc TclpMatchInDirectory; +Tcl_FSChdirProc TclpObjChdir; +Tcl_FSLstatProc TclpObjLstat; +Tcl_FSCopyFileProc TclpObjCopyFile; +Tcl_FSDeleteFileProc TclpObjDeleteFile; +Tcl_FSRenameFileProc TclpObjRenameFile; +Tcl_FSCreateDirectoryProc TclpObjCreateDirectory; +Tcl_FSCopyDirectoryProc TclpObjCopyDirectory; +Tcl_FSRemoveDirectoryProc TclpObjRemoveDirectory; +Tcl_FSUnloadFileProc TclpUnloadFile; +Tcl_FSLinkProc TclpObjLink; +Tcl_FSListVolumesProc TclpObjListVolumes; /* - * Define the native filesystem dispatch table. If necessary, it is ok to - * make this non-static, but it should only be accessed by the functions - * actually listed within it (or perhaps other helper functions of them). - * Anything which is not part of this 'native filesystem implementation' - * should not be delving inside here! + * Define the native filesystem dispatch table. If necessary, it is ok to make + * this non-static, but it should only be accessed by the functions actually + * listed within it (or perhaps other helper functions of them). Anything + * which is not part of this 'native filesystem implementation' should not be + * delving inside here! */ Tcl_Filesystem tclNativeFilesystem = { @@ -370,17 +369,17 @@ Tcl_Filesystem tclNativeFilesystem = { &TclpObjLstat, &TclpDlopen, /* Needs a cast since we're using version_2 */ - (Tcl_FSGetCwdProc*)&TclpGetNativeCwd, + (Tcl_FSGetCwdProc *) &TclpGetNativeCwd, &TclpObjChdir }; /* - * Define the tail of the linked list. Note that for unconventional uses of + * Define the tail of the linked list. Note that for unconventional uses of * Tcl without a native filesystem, we may in the future wish to modify the * current approach of hard-coding the native filesystem in the lookup list * 'filesystemList' below. * - * We initialize the record so that it thinks one file uses it. This means it + * We initialize the record so that it thinks one file uses it. This means it * will never be freed. */ @@ -392,10 +391,10 @@ static FilesystemRecord nativeFilesystemRecord = { }; /* - * This is incremented each time we modify the linked list of filesystems. - * Any time it changes, all cached filesystem representations are suspect and - * must be freed. For multithreading builds, change of the filesystem epoch - * will trigger cache cleanup in all threads. + * This is incremented each time we modify the linked list of filesystems. Any + * time it changes, all cached filesystem representations are suspect and must + * be freed. For multithreading builds, change of the filesystem epoch will + * trigger cache cleanup in all threads. */ static int theFilesystemEpoch = 0; @@ -424,12 +423,12 @@ Tcl_ThreadDataKey tclFsDataKey; * Declare fallback support function and information for Tcl_FSLoadFile */ -static Tcl_FSUnloadFileProc FSUnloadTempFile; +static Tcl_FSUnloadFileProc FSUnloadTempFile; /* * One of these structures is used each time we successfully load a file from * a file system by way of making a temporary copy of the file on the native - * filesystem. We need to store both the actual unloadProc/clientData + * filesystem. We need to store both the actual unloadProc/clientData * combination which was used, and the original and modified filenames, so * that we can correctly undo the entire operation when we want to unload the * code. @@ -448,8 +447,8 @@ typedef struct FsDivertLoad { */ static void -FsThrExitProc(cd) - ClientData cd; +FsThrExitProc( + ClientData cd) { ThreadSpecificData *tsdPtr = (ThreadSpecificData *) cd; FilesystemRecord *fsRecPtr = NULL, *tmpFsRecPtr = NULL; @@ -480,7 +479,7 @@ FsThrExitProc(cd) } int -TclFSCwdIsNative() +TclFSCwdIsNative(void) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); @@ -504,7 +503,7 @@ TclFSCwdIsNative() * * Side effects: * If the paths are equal, but are not the same object, this method will - * modify the given pathPtrPtr to refer to the same object. In this case + * modify the given pathPtrPtr to refer to the same object. In this case * the object pointed to by pathPtrPtr will have its refCount * decremented, and it will be adjusted to point to the cwd (with a new * refCount). @@ -513,8 +512,8 @@ TclFSCwdIsNative() */ int -TclFSCwdPointerEquals(pathPtrPtr) - Tcl_Obj** pathPtrPtr; +TclFSCwdPointerEquals( + Tcl_Obj** pathPtrPtr) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); @@ -561,7 +560,7 @@ TclFSCwdPointerEquals(pathPtrPtr) str2 = Tcl_GetStringFromObj(*pathPtrPtr, &len2); if (len1 == len2 && !strcmp(str1,str2)) { /* - * They are equal, but different objects. Update so they will be + * They are equal, but different objects. Update so they will be * the same object in the future. */ @@ -638,7 +637,8 @@ FsRecacheFilesystemList(void) #endif /* TCL_THREADS */ static FilesystemRecord * -FsGetFirstFilesystem(void) { +FsGetFirstFilesystem(void) +{ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); FilesystemRecord *fsRecPtr; #ifndef TCL_THREADS @@ -663,8 +663,8 @@ FsGetFirstFilesystem(void) { */ int -TclFSEpochOk(filesystemEpoch) - int filesystemEpoch; +TclFSEpochOk( + int filesystemEpoch) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); (void) FsGetFirstFilesystem(); @@ -676,9 +676,9 @@ TclFSEpochOk(filesystemEpoch) */ static void -FsUpdateCwd(cwdObj, clientData) - Tcl_Obj *cwdObj; - ClientData clientData; +FsUpdateCwd( + Tcl_Obj *cwdObj, + ClientData clientData) { int len; char *str = NULL; @@ -735,8 +735,8 @@ FsUpdateCwd(cwdObj, clientData) * * TclFinalizeFilesystem -- * - * Clean up the filesystem. After this, calls to all Tcl_FS... - * functions will fail. + * Clean up the filesystem. After this, calls to all Tcl_FS... functions + * will fail. * * We will later call TclResetFilesystem to restore the FS to a pristine * state. @@ -751,12 +751,12 @@ FsUpdateCwd(cwdObj, clientData) */ void -TclFinalizeFilesystem() +TclFinalizeFilesystem(void) { FilesystemRecord *fsRecPtr; /* - * Assumption that only one thread is active now. Otherwise we would need + * Assumption that only one thread is active now. Otherwise we would need * to put various mutexes around this code. */ @@ -821,7 +821,7 @@ TclFinalizeFilesystem() */ void -TclResetFilesystem() +TclResetFilesystem(void) { filesystemList = &nativeFilesystemRecord; @@ -851,7 +851,7 @@ TclResetFilesystem() * can use Tcl_FSData to check if it is in the list, provided the * ClientData used was not NULL). * - * Note that the filesystem handling is head-to-tail of the list. Each + * Note that the filesystem handling is head-to-tail of the list. Each * filesystem is asked in turn whether it can handle a particular * request, until one of them says 'yes'. At that point no further * filesystems are asked. @@ -871,9 +871,9 @@ TclResetFilesystem() */ int -Tcl_FSRegister(clientData, fsPtr) - ClientData clientData; /* Client specific data for this fs */ - Tcl_Filesystem *fsPtr; /* The filesystem record for the new fs. */ +Tcl_FSRegister( + ClientData clientData, /* Client specific data for this fs */ + Tcl_Filesystem *fsPtr) /* The filesystem record for the new fs. */ { FilesystemRecord *newFilesystemPtr; @@ -887,17 +887,17 @@ Tcl_FSRegister(clientData, fsPtr) newFilesystemPtr->fsPtr = fsPtr; /* - * We start with a refCount of 1. If this drops to zero, then anyone is + * We start with a refCount of 1. If this drops to zero, then anyone is * welcome to ckfree us. */ newFilesystemPtr->fileRefCount = 1; /* - * Is this lock and wait strictly speaking necessary? Since any iterators + * Is this lock and wait strictly speaking necessary? Since any iterators * out there will have grabbed a copy of the head of the list and be * iterating away from that, if we add a new element to the head of the - * list, it can't possibly have any effect on any of their loops. In fact + * list, it can't possibly have any effect on any of their loops. In fact * it could be better not to wait, since we are adjusting the filesystem * epoch, any cached representations calculated by existing iterators are * going to have to be thrown away anyway. @@ -932,14 +932,14 @@ Tcl_FSRegister(clientData, fsPtr) * Tcl_FSUnregister -- * * Remove the passed filesystem from the list of filesystem function - * tables. It also ensures that the built-in (native) filesystem is not + * tables. It also ensures that the built-in (native) filesystem is not * removable, although we may wish to change that decision in the future * to allow a smaller Tcl core, in which the native filesystem is not * used at all (we could, say, initialise Tcl completely over a network * connection). * * Results: - * TCL_OK if the procedure pointer was successfully removed, TCL_ERROR + * TCL_OK if the function pointer was successfully removed, TCL_ERROR * otherwise. * * Side effects: @@ -951,8 +951,8 @@ Tcl_FSRegister(clientData, fsPtr) */ int -Tcl_FSUnregister(fsPtr) - Tcl_Filesystem *fsPtr; /* The filesystem record to remove. */ +Tcl_FSUnregister( + Tcl_Filesystem *fsPtr) /* The filesystem record to remove. */ { int retVal = TCL_ERROR; FilesystemRecord *fsRecPtr; @@ -979,7 +979,7 @@ Tcl_FSUnregister(fsPtr) /* * Increment the filesystem epoch counter, since existing paths - * might conceivably now belong to different filesystems. This + * might conceivably now belong to different filesystems. This * should also ensure that paths which have cached the filesystem * which is about to be deleted do not reference that filesystem * (which would of course lead to memory exceptions). @@ -1008,17 +1008,17 @@ Tcl_FSUnregister(fsPtr) * Tcl_FSMatchInDirectory -- * * This routine is used by the globbing code to search a directory for - * all files which match a given pattern. The appropriate function for - * the filesystem to which pathPtr belongs will be called. If pathPtr + * all files which match a given pattern. The appropriate function for + * the filesystem to which pathPtr belongs will be called. If pathPtr * does not belong to any filesystem and if it is NULL or the empty * string, then we assume the pattern is to be matched in the current - * working directory. To avoid have the Tcl_FSMatchInDirectoryProc for + * working directory. To avoid have the Tcl_FSMatchInDirectoryProc for * each filesystem from having to deal with this issue, we create a * pathPtr on the fly (equal to the cwd), and then remove it from the - * results returned. This makes filesystems easy to write, since they - * can assume the pathPtr passed to them is an ordinary path. In fact - * this means we could remove such special case handling from Tcl's - * native filesystems. + * results returned. This makes filesystems easy to write, since they can + * assume the pathPtr passed to them is an ordinary path. In fact this + * means we could remove such special case handling from Tcl's native + * filesystems. * * If 'pattern' is NULL, then pathPtr is assumed to be a fully specified * path of a single file/directory which must be checked for existence @@ -1027,14 +1027,14 @@ Tcl_FSUnregister(fsPtr) * Results: * * The return value is a standard Tcl result indicating whether an error - * occurred in globbing. Error messages are placed in interp, but good + * occurred in globbing. Error messages are placed in interp, but good * results are placed in the resultPtr given. * * Recursive searches, e.g. * glob -dir $dir -join * pkgIndex.tcl * which must recurse through each directory matching '*' are handled * internally by Tcl, by passing specific flags in a modified 'types' - * parameter. This means the actual filesystem only ever sees patterns + * parameter. This means the actual filesystem only ever sees patterns * which match in a single directory. * * Side effects: @@ -1044,13 +1044,13 @@ Tcl_FSUnregister(fsPtr) */ int -Tcl_FSMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) - Tcl_Interp *interp; /* Interpreter to receive error - * messages, but may be NULL. */ - Tcl_Obj *resultPtr; /* List object to receive results. */ - Tcl_Obj *pathPtr; /* Contains path to directory to search. */ - CONST char *pattern; /* Pattern to match against. */ - Tcl_GlobTypeData *types; /* Object containing list of acceptable types. +Tcl_FSMatchInDirectory( + Tcl_Interp *interp, /* Interpreter to receive error messages, but + * may be NULL. */ + Tcl_Obj *resultPtr, /* List object to receive results. */ + Tcl_Obj *pathPtr, /* Contains path to directory to search. */ + CONST char *pattern, /* Pattern to match against. */ + Tcl_GlobTypeData *types) /* Object containing list of acceptable types. * May be NULL. In particular the directory * flag is very important. */ { @@ -1063,7 +1063,7 @@ Tcl_FSMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) * We don't currently allow querying of mounts by external code (a * valuable future step), so since we're the only function that * actually knows about mounts, this means we're being called - * recursively by ourself. Return no matches. + * recursively by ourself. Return no matches. */ return TCL_OK; @@ -1154,7 +1154,7 @@ Tcl_FSMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) * FsAddMountsToGlobResult -- * * This routine is used by the globbing code to take the results of a - * directory listing and add any mounted paths to that listing. This is + * directory listing and add any mounted paths to that listing. This is * required so that simple things like 'glob *' merge mounts and listings * correctly. * @@ -1168,12 +1168,12 @@ Tcl_FSMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) */ static void -FsAddMountsToGlobResult(resultPtr, pathPtr, pattern, types) - Tcl_Obj *resultPtr; /* The current list of matching paths; must +FsAddMountsToGlobResult( + Tcl_Obj *resultPtr, /* The current list of matching paths; must * not be shared! */ - Tcl_Obj *pathPtr; /* The directory in question */ - CONST char *pattern; /* Pattern to match against. */ - Tcl_GlobTypeData *types; /* Object containing list of acceptable types. + Tcl_Obj *pathPtr, /* The directory in question */ + CONST char *pattern, /* Pattern to match against. */ + Tcl_GlobTypeData *types) /* Object containing list of acceptable types. * May be NULL. In particular the directory * flag is very important. */ { @@ -1268,7 +1268,7 @@ FsAddMountsToGlobResult(resultPtr, pathPtr, pattern, types) * Clearly it should only therefore be called when it is really required! * There are a few circumstances when it should be called: * - * (1) when a new filesystem is registered or unregistered. Strictly + * (1) when a new filesystem is registered or unregistered. Strictly * speaking this is only necessary if the new filesystem accepts file * paths as is (normally the filesystem itself is really a shell which * hasn't yet had any mount points established and so its @@ -1298,11 +1298,11 @@ FsAddMountsToGlobResult(resultPtr, pathPtr, pattern, types) */ void -Tcl_FSMountsChanged(fsPtr) - Tcl_Filesystem *fsPtr; +Tcl_FSMountsChanged( + Tcl_Filesystem *fsPtr) { /* - * We currently don't do anything with this parameter. We could in the + * We currently don't do anything with this parameter. We could in the * future only invalidate files for this filesystem or otherwise take more * advanced action. */ @@ -1328,7 +1328,7 @@ Tcl_FSMountsChanged(fsPtr) * that filesystem is not registered. * * Results: - * A clientData value, or NULL. Note that if the filesystem was + * A clientData value, or NULL. Note that if the filesystem was * registered with a NULL clientData field, this function will return * that NULL value. * @@ -1339,14 +1339,14 @@ Tcl_FSMountsChanged(fsPtr) */ ClientData -Tcl_FSData(fsPtr) - Tcl_Filesystem *fsPtr; /* The filesystem record to query. */ +Tcl_FSData( + Tcl_Filesystem *fsPtr) /* The filesystem record to query. */ { ClientData retVal = NULL; FilesystemRecord *fsRecPtr = FsGetFirstFilesystem(); /* - * Traverse the list of filesystems look for a particular one. If found, + * Traverse the list of filesystems look for a particular one. If found, * return that filesystem's clientData (originally provided when calling * Tcl_FSRegister). */ @@ -1367,13 +1367,13 @@ Tcl_FSData(fsPtr) * TclFSNormalizeToUniquePath -- * * Takes a path specification containing no ../, ./ sequences, and - * converts it into a unique path for the given platform. On Unix, this + * converts it into a unique path for the given platform. On Unix, this * means the path must be free of symbolic links/aliases, and on Windows * it means we want the long form, with that long form's case-dependence * (which gives us a unique, case-dependent path). * * Results: - * The pathPtr is modified in place. The return value is the last byte + * The pathPtr is modified in place. The return value is the last byte * offset which was recognised in the path string. * * Side effects: @@ -1382,7 +1382,7 @@ Tcl_FSData(fsPtr) * Special notes: * If the filesystem-specific normalizePathProcs can re-introduce ../, ./ * sequences into the path, then this function will not return the - * correct result. This may be possible with symbolic links on unix. + * correct result. This may be possible with symbolic links on unix. * * Important assumption: if startAt is non-zero, it must point to a * directory separator that we know exists and is already normalized (so @@ -1392,11 +1392,11 @@ Tcl_FSData(fsPtr) */ int -TclFSNormalizeToUniquePath(interp, pathPtr, startAt, clientDataPtr) - Tcl_Interp *interp; /* Used for error messages. */ - Tcl_Obj *pathPtr; /* The path to normalize in place */ - int startAt; /* Start at this char-offset */ - ClientData *clientDataPtr; /* If we generated a complete normalized path +TclFSNormalizeToUniquePath( + Tcl_Interp *interp, /* Used for error messages. */ + Tcl_Obj *pathPtr, /* The path to normalize in place */ + int startAt, /* Start at this char-offset */ + ClientData *clientDataPtr) /* If we generated a complete normalized path * for a given filesystem, we can optionally * return an fs-specific clientdata here. */ { @@ -1407,7 +1407,7 @@ TclFSNormalizeToUniquePath(interp, pathPtr, startAt, clientDataPtr) /* * Call each of the "normalise path" functions in succession. This is a * special case, in which if we have a native filesystem handler, we call - * it first. This is because the root of Tcl's filesystem is always a + * it first. This is because the root of Tcl's filesystem is always a * native filesystem (i.e. '/' on unix is native). */ @@ -1455,7 +1455,7 @@ TclFSNormalizeToUniquePath(interp, pathPtr, startAt, clientDataPtr) * TclGetOpenMode -- * * This routine is an obsolete, limited version of TclGetOpenModeEx() - * below. It exists only to satisfy any extensions imprudently using it + * below. It exists only to satisfy any extensions imprudently using it * via Tcl's internal stubs table. * * Results: @@ -1468,14 +1468,12 @@ TclFSNormalizeToUniquePath(interp, pathPtr, startAt, clientDataPtr) */ int -TclGetOpenMode(interp, modeString, seekFlagPtr) - Tcl_Interp *interp; /* Interpreter to use for error - * reporting - may be NULL. */ - CONST char *modeString; /* Mode string, e.g. "r+" or "RDONLY - * CREAT". */ - int *seekFlagPtr; /* Set this to 1 if the caller should - * seek to EOF during the opening of - * the file. */ +TclGetOpenMode( + Tcl_Interp *interp, /* Interpreter to use for error reporting - + * may be NULL. */ + CONST char *modeString, /* Mode string, e.g. "r+" or "RDONLY CREAT" */ + int *seekFlagPtr) /* Set this to 1 if the caller should seek to + * EOF during the opening of the file. */ { int binary = 0; return TclGetOpenModeEx(interp, modeString, seekFlagPtr, &binary); @@ -1498,7 +1496,7 @@ TclGetOpenMode(interp, modeString, seekFlagPtr) * * Side effects: * Sets the integer referenced by seekFlagPtr to 1 to tell the caller to - * seek to EOF after opening the file, or to 0 otherwise. Sets the + * seek to EOF after opening the file, or to 0 otherwise. Sets the * integer referenced by binaryPtr to 1 to tell the caller to seek to * configure the channel for binary data, or to 0 otherwise. * @@ -1510,24 +1508,22 @@ TclGetOpenMode(interp, modeString, seekFlagPtr) */ int -TclGetOpenModeEx(interp, modeString, seekFlagPtr, binaryPtr) - Tcl_Interp *interp; /* Interpreter to use for error - * reporting - may be NULL. */ - CONST char *modeString; /* Mode string, e.g. "r+" or "RDONLY - * CREAT". */ - int *seekFlagPtr; /* Set this to 1 if the caller should - * seek to EOF during the opening of - * the file. */ - int *binaryPtr; /* Set this to 1 if the caller should - * configure the opened channel for - * binary operations */ +TclGetOpenModeEx( + Tcl_Interp *interp, /* Interpreter to use for error reporting - + * may be NULL. */ + CONST char *modeString, /* Mode string, e.g. "r+" or "RDONLY CREAT" */ + int *seekFlagPtr, /* Set this to 1 if the caller should seek to + * EOF during the opening of the file. */ + int *binaryPtr) /* Set this to 1 if the caller should + * configure the opened channel for binary + * operations */ { int mode, modeArgc, c, i, gotRW; CONST char **modeArgv, *flag; #define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR) /* - * Check for the simpler fopen-like access modes (e.g. "r"). They are + * Check for the simpler fopen-like access modes (e.g. "r"). They are * distinguished from the POSIX access modes by the presence of a * lower-case first letter. */ @@ -1558,9 +1554,9 @@ TclGetOpenModeEx(interp, modeString, seekFlagPtr, binaryPtr) error: *seekFlagPtr = 0; *binaryPtr = 0; - if (interp != (Tcl_Interp *) NULL) { + if (interp != NULL) { Tcl_AppendResult(interp, "illegal access mode \"", modeString, - "\"", (char *) NULL); + "\"", NULL); } return -1; } @@ -1596,7 +1592,7 @@ TclGetOpenModeEx(interp, modeString, seekFlagPtr, binaryPtr) */ if (Tcl_SplitList(interp, modeString, &modeArgc, &modeArgv) != TCL_OK) { - if (interp != (Tcl_Interp *) NULL) { + if (interp != NULL) { Tcl_AddErrorInfo(interp, "\n while processing open access modes \""); Tcl_AddErrorInfo(interp, modeString); @@ -1630,9 +1626,9 @@ TclGetOpenModeEx(interp, modeString, seekFlagPtr, binaryPtr) #ifdef O_NOCTTY mode |= O_NOCTTY; #else - if (interp != (Tcl_Interp *) NULL) { + if (interp != NULL) { Tcl_AppendResult(interp, "access mode \"", flag, - "\" not supported by this system", (char *) NULL); + "\" not supported by this system", NULL); } ckfree((char *) modeArgv); return -1; @@ -1647,9 +1643,9 @@ TclGetOpenModeEx(interp, modeString, seekFlagPtr, binaryPtr) # endif #else - if (interp != (Tcl_Interp *) NULL) { + if (interp != NULL) { Tcl_AppendResult(interp, "access mode \"", flag, - "\" not supported by this system", (char *) NULL); + "\" not supported by this system", NULL); } ckfree((char *) modeArgv); return -1; @@ -1661,11 +1657,10 @@ TclGetOpenModeEx(interp, modeString, seekFlagPtr, binaryPtr) *binaryPtr = 1; } else { - if (interp != (Tcl_Interp *) NULL) { + if (interp != NULL) { Tcl_AppendResult(interp, "invalid access mode \"", flag, "\": must be RDONLY, WRONLY, RDWR, APPEND, BINARY, " - "CREAT, EXCL, NOCTTY, NONBLOCK, or TRUNC", - (char *) NULL); + "CREAT, EXCL, NOCTTY, NONBLOCK, or TRUNC", NULL); } ckfree((char *) modeArgv); return -1; @@ -1675,9 +1670,9 @@ TclGetOpenModeEx(interp, modeString, seekFlagPtr, binaryPtr) ckfree((char *) modeArgv); if (!gotRW) { - if (interp != (Tcl_Interp *) NULL) { + if (interp != NULL) { Tcl_AppendResult(interp, "access mode must include either", - " RDONLY, WRONLY, or RDWR", (char *) NULL); + " RDONLY, WRONLY, or RDWR", NULL); } return -1; } @@ -1689,9 +1684,9 @@ TclGetOpenModeEx(interp, modeString, seekFlagPtr, binaryPtr) */ int -Tcl_FSEvalFile(interp, pathPtr) - Tcl_Interp *interp; /* Interpreter in which to process file. */ - Tcl_Obj *pathPtr; /* Path of file to process. Tilde-substitution +Tcl_FSEvalFile( + Tcl_Interp *interp, /* Interpreter in which to process file. */ + Tcl_Obj *pathPtr) /* Path of file to process. Tilde-substitution * will be performed on this name. */ { return Tcl_FSEvalFileEx(interp, pathPtr, NULL); @@ -1710,7 +1705,7 @@ Tcl_FSEvalFile(interp, pathPtr) * file or an error indicating why the file couldn't be read. * * Side effects: - * Depends on the commands in the file. During the evaluation of the + * Depends on the commands in the file. During the evaluation of the * contents of the file, iPtr->scriptFile is made to point to pathPtr * (the old value is cached and replaced when this function returns). * @@ -1718,12 +1713,12 @@ Tcl_FSEvalFile(interp, pathPtr) */ int -Tcl_FSEvalFileEx(interp, pathPtr, encodingName) - Tcl_Interp *interp; /* Interpreter in which to process file. */ - Tcl_Obj *pathPtr; /* Path of file to process. Tilde-substitution +Tcl_FSEvalFileEx( + Tcl_Interp *interp, /* Interpreter in which to process file. */ + Tcl_Obj *pathPtr, /* Path of file to process. Tilde-substitution * will be performed on this name. */ - CONST char *encodingName; /* If non-NULL, then use this encoding for the - * file. */ + CONST char *encodingName) /* If non-NULL, then use this encoding for the + * file. NULL means use the system encoding. */ { int result, length; Tcl_StatBuf statBuf; @@ -1743,28 +1738,26 @@ Tcl_FSEvalFileEx(interp, pathPtr, encodingName) if (Tcl_FSStat(pathPtr, &statBuf) == -1) { Tcl_SetErrno(errno); Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), - "\": ", Tcl_PosixError(interp), (char *) NULL); + Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); goto end; } chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644); if (chan == (Tcl_Channel) NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), - "\": ", Tcl_PosixError(interp), (char *) NULL); + Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); goto end; } /* - * The eofchar is \32 (^Z). This is the usual on Windows, but we effect - * this cross-platform to allow for scripted documents. [Bug: 2040] + * The eofchar is \32 (^Z). This is the usual on Windows, but we effect + * this cross-platform to allow for scripted documents. [Bug: 2040] */ Tcl_SetChannelOption(interp, chan, "-eofchar", "\32"); /* - * If the encoding is specified, set it for the channel. Else don't touch + * If the encoding is specified, set it for the channel. Else don't touch * it (and use the system encoding) Report error on unknown encoding. */ @@ -1779,8 +1772,7 @@ Tcl_FSEvalFileEx(interp, pathPtr, encodingName) if (Tcl_ReadChars(chan, objPtr, -1, 0) < 0) { Tcl_Close(interp, chan); Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), - "\": ", Tcl_PosixError(interp), (char *) NULL); + Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); goto end; } @@ -1812,6 +1804,7 @@ Tcl_FSEvalFileEx(interp, pathPtr, encodingName) /* * Record information telling where the error occurred. */ + CONST char *pathString = Tcl_GetStringFromObj(pathPtr, &length); int limit = 150; int overflow = (length > limit); @@ -1846,7 +1839,7 @@ Tcl_FSEvalFileEx(interp, pathPtr, encodingName) */ int -Tcl_GetErrno() +Tcl_GetErrno(void) { return errno; } @@ -1868,8 +1861,8 @@ Tcl_GetErrno() */ void -Tcl_SetErrno(err) - int err; /* The new value. */ +Tcl_SetErrno( + int err) /* The new value. */ { errno = err; } @@ -1879,8 +1872,8 @@ Tcl_SetErrno(err) * * Tcl_PosixError -- * - * This procedure is typically called after UNIX kernel calls return - * errors. It stores machine-readable information about the error in + * This function is typically called after UNIX kernel calls return + * errors. It stores machine-readable information about the error in * errorCode field of interp and returns an information string for the * caller's use. * @@ -1894,15 +1887,15 @@ Tcl_SetErrno(err) */ CONST char * -Tcl_PosixError(interp) - Tcl_Interp *interp; /* Interpreter whose errorCode field - * is to be set. */ +Tcl_PosixError( + Tcl_Interp *interp) /* Interpreter whose errorCode field is to be + * set. */ { CONST char *id, *msg; msg = Tcl_ErrnoMsg(errno); id = Tcl_ErrnoId(); - Tcl_SetErrorCode(interp, "POSIX", id, msg, (char *) NULL); + Tcl_SetErrorCode(interp, "POSIX", id, msg, NULL); return msg; } @@ -1911,7 +1904,7 @@ Tcl_PosixError(interp) * * Tcl_FSStat -- * - * This procedure replaces the library version of stat and lsat. + * This function replaces the library version of stat and lsat. * * The appropriate function for the filesystem to which pathPtr belongs * will be called. @@ -1926,9 +1919,9 @@ Tcl_PosixError(interp) */ int -Tcl_FSStat(pathPtr, buf) - Tcl_Obj *pathPtr; /* Path of file to stat (in current CP). */ - Tcl_StatBuf *buf; /* Filled with results of stat call. */ +Tcl_FSStat( + Tcl_Obj *pathPtr, /* Path of file to stat (in current CP). */ + Tcl_StatBuf *buf) /* Filled with results of stat call. */ { Tcl_Filesystem *fsPtr; #ifdef USE_OBSOLETE_FS_HOOKS @@ -1936,7 +1929,7 @@ Tcl_FSStat(pathPtr, buf) int retVal = -1; /* - * Call each of the "stat" function in succession. A non-return value of + * Call each of the "stat" function in succession. A non-return value of * -1 indicates the particular function has succeeded. */ @@ -2004,7 +1997,7 @@ Tcl_FSStat(pathPtr, buf) * * Tcl_FSLstat -- * - * This procedure replaces the library version of lstat. The appropriate + * This function replaces the library version of lstat. The appropriate * function for the filesystem to which pathPtr belongs will be called. * If no 'lstat' function is listed, but a 'stat' function is, then Tcl * will fall back on the stat function. @@ -2019,9 +2012,9 @@ Tcl_FSStat(pathPtr, buf) */ int -Tcl_FSLstat(pathPtr, buf) - Tcl_Obj *pathPtr; /* Path of file to stat (in current CP). */ - Tcl_StatBuf *buf; /* Filled with results of stat call. */ +Tcl_FSLstat( + Tcl_Obj *pathPtr, /* Path of file to stat (in current CP). */ + Tcl_StatBuf *buf) /* Filled with results of stat call. */ { Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL) { @@ -2044,9 +2037,8 @@ Tcl_FSLstat(pathPtr, buf) * * Tcl_FSAccess -- * - * This procedure replaces the library version of access. The - * appropriate function for the filesystem to which pathPtr belongs will - * be called. + * This function replaces the library version of access. The appropriate + * function for the filesystem to which pathPtr belongs will be called. * * Results: * See access documentation. @@ -2058,17 +2050,17 @@ Tcl_FSLstat(pathPtr, buf) */ int -Tcl_FSAccess(pathPtr, mode) - Tcl_Obj *pathPtr; /* Path of file to access (in current CP). */ - int mode; /* Permission setting. */ +Tcl_FSAccess( + Tcl_Obj *pathPtr, /* Path of file to access (in current CP). */ + int mode) /* Permission setting. */ { Tcl_Filesystem *fsPtr; #ifdef USE_OBSOLETE_FS_HOOKS int retVal = -1; /* - * Call each of the "access" function in succession. A non-return value - * of -1 indicates the particular function has succeeded. + * Call each of the "access" function in succession. A non-return value of + * -1 indicates the particular function has succeeded. */ Tcl_MutexLock(&obsoleteFsHookMutex); @@ -2130,13 +2122,13 @@ Tcl_FSAccess(pathPtr, mode) */ Tcl_Channel -Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions) - Tcl_Interp *interp; /* Interpreter for error reporting; can be +Tcl_FSOpenFileChannel( + Tcl_Interp *interp, /* Interpreter for error reporting; can be * NULL. */ - Tcl_Obj *pathPtr; /* Name of file to open. */ - CONST char *modeString; /* A list of POSIX open modes or a string such + Tcl_Obj *pathPtr, /* Name of file to open. */ + CONST char *modeString, /* A list of POSIX open modes or a string such * as "rw". */ - int permissions; /* If the open involves creating a file, with + int permissions) /* If the open involves creating a file, with * what modes to create it? */ { Tcl_Filesystem *fsPtr; @@ -2144,7 +2136,7 @@ Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions) Tcl_Channel retVal = NULL; /* - * Call each of the "Tcl_OpenFileChannel" functions in succession. A + * Call each of the "Tcl_OpenFileChannel" functions in succession. A * non-NULL return value indicates the particular function has succeeded. */ @@ -2192,30 +2184,41 @@ Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions) if (proc != NULL) { int mode, seekFlag, binary; + /* + * Parse the mode, picking up whether we want to seek to start + * with and/or set the channel automatically into binary mode. + */ + mode = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary); if (mode == -1) { return NULL; } + /* + * Do the actual open() call. + */ + retVal = (*proc)(interp, pathPtr, mode, permissions); - if (retVal != NULL) { - if (seekFlag) { - if (Tcl_Seek(retVal, (Tcl_WideInt)0, - SEEK_END) < (Tcl_WideInt)0) { - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, - "could not seek to end of file while opening \"", - Tcl_GetString(pathPtr), "\": ", - Tcl_PosixError(interp), (char *) NULL); - } - Tcl_Close(NULL, retVal); - return NULL; - } - } - if (binary) { - Tcl_SetChannelOption(interp, retVal, - "-translation", "binary"); + if (retVal == NULL) { + return NULL; + } + + /* + * Apply appropriate flags parsed out above. + */ + + if (seekFlag && Tcl_Seek(retVal, (Tcl_WideInt)0, + SEEK_END) < (Tcl_WideInt)0) { + if (interp != NULL) { + Tcl_AppendResult(interp, "could not seek to end ", + "of file while opening \"", Tcl_GetString(pathPtr), + "\": ", Tcl_PosixError(interp), NULL); } + Tcl_Close(NULL, retVal); + return NULL; + } + if (binary) { + Tcl_SetChannelOption(interp, retVal, "-translation", "binary"); } return retVal; } @@ -2228,7 +2231,7 @@ Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions) Tcl_SetErrno(ENOENT); if (interp != NULL) { Tcl_AppendResult(interp, "couldn't open \"", Tcl_GetString(pathPtr), - "\": ", Tcl_PosixError(interp), (char *) NULL); + "\": ", Tcl_PosixError(interp), NULL); } return NULL; } @@ -2238,7 +2241,7 @@ Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions) * * Tcl_FSUtime -- * - * This procedure replaces the library version of utime. The appropriate + * This function replaces the library version of utime. The appropriate * function for the filesystem to which pathPtr belongs will be called. * * Results: @@ -2251,10 +2254,10 @@ Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions) */ int -Tcl_FSUtime(pathPtr, tval) - Tcl_Obj *pathPtr; /* File to change access/modification times */ - struct utimbuf *tval; /* Structure containing access/modification - * times to use. Should not be modified. */ +Tcl_FSUtime( + Tcl_Obj *pathPtr, /* File to change access/modification times */ + struct utimbuf *tval) /* Structure containing access/modification + * times to use. Should not be modified. */ { Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL) { @@ -2271,9 +2274,9 @@ Tcl_FSUtime(pathPtr, tval) * * NativeFileAttrStrings -- * - * This procedure implements the platform dependent 'file attributes' + * This function implements the platform dependent 'file attributes' * subcommand, for the native filesystem, for listing the set of possible - * attribute strings. This function is part of Tcl's native filesystem + * attribute strings. This function is part of Tcl's native filesystem * support, and is placed here because it is shared by Unix and Windows * code. * @@ -2286,10 +2289,10 @@ Tcl_FSUtime(pathPtr, tval) *---------------------------------------------------------------------- */ -static CONST char** -NativeFileAttrStrings(pathPtr, objPtrRef) - Tcl_Obj *pathPtr; - Tcl_Obj** objPtrRef; +static CONST char ** +NativeFileAttrStrings( + Tcl_Obj *pathPtr, + Tcl_Obj **objPtrRef) { return tclpFileAttrStrings; } @@ -2299,15 +2302,15 @@ NativeFileAttrStrings(pathPtr, objPtrRef) * * NativeFileAttrsGet -- * - * This procedure implements the platform dependent 'file attributes' - * subcommand, for the native filesystem, for 'get' operations. This + * This function implements the platform dependent 'file attributes' + * subcommand, for the native filesystem, for 'get' operations. This * function is part of Tcl's native filesystem support, and is placed * here because it is shared by Unix and Windows code. * * Results: - * Standard Tcl return code. The object placed in objPtrRef (if TCL_OK - * was returned) is likely to have a refCount of zero. Either way we - * must either store it somewhere (e.g. the Tcl result), or Incr/Decr its + * Standard Tcl return code. The object placed in objPtrRef (if TCL_OK + * was returned) is likely to have a refCount of zero. Either way we must + * either store it somewhere (e.g. the Tcl result), or Incr/Decr its * refCount to ensure it is properly freed. * * Side effects: @@ -2317,13 +2320,13 @@ NativeFileAttrStrings(pathPtr, objPtrRef) */ static int -NativeFileAttrsGet(interp, index, pathPtr, objPtrRef) - Tcl_Interp *interp; /* The interpreter for error reporting. */ - int index; /* index of the attribute command. */ - Tcl_Obj *pathPtr; /* path of file we are operating on. */ - Tcl_Obj **objPtrRef; /* for output. */ +NativeFileAttrsGet( + Tcl_Interp *interp, /* The interpreter for error reporting. */ + int index, /* index of the attribute command. */ + Tcl_Obj *pathPtr, /* path of file we are operating on. */ + Tcl_Obj **objPtrRef) /* for output. */ { - return (*tclpFileAttrProcs[index].getProc)(interp, index, pathPtr, + return (tclpFileAttrProcs[index]->getProc)(interp, index, pathPtr, objPtrRef); } @@ -2332,7 +2335,7 @@ NativeFileAttrsGet(interp, index, pathPtr, objPtrRef) * * NativeFileAttrsSet -- * - * This procedure implements the platform dependent 'file attributes' + * This function implements the platform dependent 'file attributes' * subcommand, for the native filesystem, for 'set' operations. This * function is part of Tcl's native filesystem support, and is placed * here because it is shared by Unix and Windows code. @@ -2347,13 +2350,13 @@ NativeFileAttrsGet(interp, index, pathPtr, objPtrRef) */ static int -NativeFileAttrsSet(interp, index, pathPtr, objPtr) - Tcl_Interp *interp; /* The interpreter for error reporting. */ - int index; /* index of the attribute command. */ - Tcl_Obj *pathPtr; /* path of file we are operating on. */ - Tcl_Obj *objPtr; /* set to this value. */ +NativeFileAttrsSet( + Tcl_Interp *interp, /* The interpreter for error reporting. */ + int index, /* index of the attribute command. */ + Tcl_Obj *pathPtr, /* path of file we are operating on. */ + Tcl_Obj *objPtr) /* set to this value. */ { - return (*tclpFileAttrProcs[index].setProc)(interp, index, pathPtr, objPtr); + return (tclpFileAttrProcs[index]->setProc)(interp, index, pathPtr, objPtr); } /* @@ -2361,12 +2364,12 @@ NativeFileAttrsSet(interp, index, pathPtr, objPtr) * * Tcl_FSFileAttrStrings -- * - * This procedure implements part of the hookable 'file attributes' - * subcommand. The appropriate function for the filesystem to which + * This function implements part of the hookable 'file attributes' + * subcommand. The appropriate function for the filesystem to which * pathPtr belongs will be called. * * Results: - * The called procedure may either return an array of strings, or may + * The called function may either return an array of strings, or may * instead return NULL and place a Tcl list into the given objPtrRef. * Tcl will take that list and first increment its refCount before using * it. On completion of that use, Tcl will decrement its refCount. Hence @@ -2381,11 +2384,12 @@ NativeFileAttrsSet(interp, index, pathPtr, objPtr) */ CONST char ** -Tcl_FSFileAttrStrings(pathPtr, objPtrRef) - Tcl_Obj *pathPtr; - Tcl_Obj **objPtrRef; +Tcl_FSFileAttrStrings( + Tcl_Obj *pathPtr, + Tcl_Obj **objPtrRef) { Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { Tcl_FSFileAttrStringsProc *proc = fsPtr->fileAttrStringsProc; if (proc != NULL) { @@ -2414,11 +2418,11 @@ Tcl_FSFileAttrStrings(pathPtr, objPtrRef) */ int -TclFSFileAttrIndex(pathPtr, attributeName, indexPtr) - Tcl_Obj *pathPtr; /* File whose attributes are to be - * indexed into. */ - CONST char *attributeName; /* The attribute being looked for. */ - int *indexPtr; /* Where to write the found index. */ +TclFSFileAttrIndex( + Tcl_Obj *pathPtr, /* File whose attributes are to be indexed + * into. */ + CONST char *attributeName, /* The attribute being looked for. */ + int *indexPtr) /* Where to write the found index. */ { Tcl_Obj *listObj = NULL; CONST char **attrTable; @@ -2478,14 +2482,14 @@ TclFSFileAttrIndex(pathPtr, attributeName, indexPtr) * * Tcl_FSFileAttrsGet -- * - * This procedure implements read access for the hookable 'file - * attributes' subcommand. The appropriate function for the filesystem - * to which pathPtr belongs will be called. + * This function implements read access for the hookable 'file + * attributes' subcommand. The appropriate function for the filesystem to + * which pathPtr belongs will be called. * * Results: - * Standard Tcl return code. The object placed in objPtrRef (if TCL_OK - * was returned) is likely to have a refCount of zero. Either way we - * must either store it somewhere (e.g. the Tcl result), or Incr/Decr its + * Standard Tcl return code. The object placed in objPtrRef (if TCL_OK + * was returned) is likely to have a refCount of zero. Either way we must + * either store it somewhere (e.g. the Tcl result), or Incr/Decr its * refCount to ensure it is properly freed. * * Side effects: @@ -2495,13 +2499,14 @@ TclFSFileAttrIndex(pathPtr, attributeName, indexPtr) */ int -Tcl_FSFileAttrsGet(interp, index, pathPtr, objPtrRef) - Tcl_Interp *interp; /* The interpreter for error reporting. */ - int index; /* index of the attribute command. */ - Tcl_Obj *pathPtr; /* filename we are operating on. */ - Tcl_Obj **objPtrRef; /* for output. */ +Tcl_FSFileAttrsGet( + Tcl_Interp *interp, /* The interpreter for error reporting. */ + int index, /* index of the attribute command. */ + Tcl_Obj *pathPtr, /* filename we are operating on. */ + Tcl_Obj **objPtrRef) /* for output. */ { Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { Tcl_FSFileAttrsGetProc *proc = fsPtr->fileAttrsGetProc; if (proc != NULL) { @@ -2517,9 +2522,9 @@ Tcl_FSFileAttrsGet(interp, index, pathPtr, objPtrRef) * * Tcl_FSFileAttrsSet -- * - * This procedure implements write access for the hookable 'file - * attributes' subcommand. The appropriate function for the filesystem - * to which pathPtr belongs will be called. + * This function implements write access for the hookable 'file + * attributes' subcommand. The appropriate function for the filesystem to + * which pathPtr belongs will be called. * * Results: * Standard Tcl return code. @@ -2531,13 +2536,14 @@ Tcl_FSFileAttrsGet(interp, index, pathPtr, objPtrRef) */ int -Tcl_FSFileAttrsSet(interp, index, pathPtr, objPtr) - Tcl_Interp *interp; /* The interpreter for error reporting. */ - int index; /* index of the attribute command. */ - Tcl_Obj *pathPtr; /* filename we are operating on. */ - Tcl_Obj *objPtr; /* Input value. */ +Tcl_FSFileAttrsSet( + Tcl_Interp *interp, /* The interpreter for error reporting. */ + int index, /* index of the attribute command. */ + Tcl_Obj *pathPtr, /* filename we are operating on. */ + Tcl_Obj *objPtr) /* Input value. */ { Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { Tcl_FSFileAttrsSetProc *proc = fsPtr->fileAttrsSetProc; if (proc != NULL) { @@ -2555,10 +2561,10 @@ Tcl_FSFileAttrsSet(interp, index, pathPtr, objPtr) * * This function replaces the library version of getcwd(). * - * Most VFS's will *not* implement a 'cwdProc'. Tcl now maintains its - * own record (in a Tcl_Obj) of the cwd, and an attempt is made to - * synchronise this with the cwd's containing filesystem, if that - * filesystem provides a cwdProc (e.g. the native filesystem). + * Most VFS's will *not* implement a 'cwdProc'. Tcl now maintains its own + * record (in a Tcl_Obj) of the cwd, and an attempt is made to synch this + * with the cwd's containing filesystem, if that filesystem provides a + * cwdProc (e.g. the native filesystem). * * Note that if Tcl's cwd is not in the native filesystem, then of course * Tcl's cwd and the native cwd are different: extensions should @@ -2575,10 +2581,10 @@ Tcl_FSFileAttrsSet(interp, index, pathPtr, objPtr) * * Results: * The result is a pointer to a Tcl_Obj specifying the current directory, - * or NULL if the current directory could not be determined. If NULL is + * or NULL if the current directory could not be determined. If NULL is * returned, an error message is left in the interp's result. * - * The result already has its refCount incremented for the caller. When + * The result already has its refCount incremented for the caller. When * it is no longer needed, that refCount should be decremented. * * Side effects: @@ -2587,9 +2593,9 @@ Tcl_FSFileAttrsSet(interp, index, pathPtr, objPtr) *---------------------------------------------------------------------- */ -Tcl_Obj* -Tcl_FSGetCwd(interp) - Tcl_Interp *interp; +Tcl_Obj * +Tcl_FSGetCwd( + Tcl_Interp *interp) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); @@ -2598,8 +2604,8 @@ Tcl_FSGetCwd(interp) Tcl_Obj *retVal = NULL; /* - * We've never been called before, try to find a cwd. Call each of - * the "Tcl_GetCwd" function in succession. A non-NULL return value + * We've never been called before, try to find a cwd. Call each of the + * "Tcl_GetCwd" function in succession. A non-NULL return value * indicates the particular function has succeeded. */ @@ -2622,15 +2628,15 @@ Tcl_FSGetCwd(interp) if (norm != NULL) { /* * We found a cwd, which is now in our global - * storage. We must make a copy. Norm already has + * storage. We must make a copy. Norm already has * a refCount of 1. * * Threading issue: note that multiple threads at * system startup could in principle call this - * procedure simultaneously. They will therefore - * each set the cwdPathPtr independently. That + * function simultaneously. They will therefore + * each set the cwdPathPtr independently. That * behaviour is a bit peculiar, but should be - * fine. Once we have a cwd, we'll always be in + * fine. Once we have a cwd, we'll always be in * the 'else' branch below which is simpler. */ @@ -2642,12 +2648,10 @@ Tcl_FSGetCwd(interp) Tcl_DecrRefCount(retVal); retVal = NULL; goto cdDidNotChange; - } else { - if (interp != NULL) { - Tcl_AppendResult(interp, - "error getting working directory name: ", - Tcl_PosixError(interp), (char *) NULL); - } + } else if (interp != NULL) { + Tcl_AppendResult(interp, + "error getting working directory name: ", + Tcl_PosixError(interp), NULL); } } else { retVal = (*proc)(interp); @@ -2669,15 +2673,15 @@ Tcl_FSGetCwd(interp) Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal, NULL); if (norm != NULL) { /* - * We found a cwd, which is now in our global storage. We - * must make a copy. Norm already has a refCount of 1. + * We found a cwd, which is now in our global storage. We must + * make a copy. Norm already has a refCount of 1. * * Threading issue: note that multiple threads at system - * startup could in principle call this procedure - * simultaneously. They will therefore each set the - * cwdPathPtr independently. That behaviour is a bit - * peculiar, but should be fine. Once we have a cwd, we'll - * always be in the 'else' branch below which is simpler. + * startup could in principle call this function + * simultaneously. They will therefore each set the cwdPathPtr + * independently. That behaviour is a bit peculiar, but should + * be fine. Once we have a cwd, we'll always be in the 'else' + * branch below which is simpler. */ ClientData cd = (ClientData) Tcl_FSGetNativePath(norm); @@ -2690,7 +2694,7 @@ Tcl_FSGetCwd(interp) /* * We already have a cwd cached, but we want to give the filesystem it * is in a chance to check whether that cwd has changed, or is perhaps - * no longer accessible. This allows an error to be thrown if, say, + * no longer accessible. This allows an error to be thrown if, say, * the permissions on that directory have changed. */ @@ -2700,7 +2704,7 @@ Tcl_FSGetCwd(interp) * If the filesystem couldn't be found, or if no cwd function exists * for this filesystem, then we simply assume the cached cwd is ok. * If we do call a cwd, we must watch for errors (if the cwd returns - * NULL). This ensures that, say, on Unix if the permissions of the + * NULL). This ensures that, say, on Unix if the permissions of the * cwd change, 'pwd' does actually throw the correct error in Tcl. * (This is tested for in the test suite on unix). */ @@ -2717,7 +2721,7 @@ Tcl_FSGetCwd(interp) if (retCd == NULL && interp != NULL) { Tcl_AppendResult(interp, "error getting working directory name: ", - Tcl_PosixError(interp), (char *) NULL); + Tcl_PosixError(interp), NULL); } if (retCd == tsdPtr->cwdClientData) { @@ -2739,7 +2743,7 @@ Tcl_FSGetCwd(interp) /* * Check whether cwd has changed from the value previously - * stored in cwdPathPtr. Really 'norm' shouldn't be null, + * stored in cwdPathPtr. Really 'norm' shouldn't be NULL, * but we are careful. */ @@ -2753,7 +2757,7 @@ Tcl_FSGetCwd(interp) } else { /* * Note that both 'norm' and 'tsdPtr->cwdPathPtr' are - * normalized paths. Therefore we can be more + * normalized paths. Therefore we can be more * efficient than calling 'Tcl_FSEqualPaths', and in * addition avoid a nasty infinite loop bug when * trying to normalize tsdPtr->cwdPathPtr. @@ -2768,7 +2772,7 @@ Tcl_FSGetCwd(interp) /* * If the paths were equal, we can be more * efficient and retain the old path object which - * will probably already be shared. In this case + * will probably already be shared. In this case * we can simply free the normalized path we just * calculated. */ @@ -2785,7 +2789,10 @@ Tcl_FSGetCwd(interp) } Tcl_DecrRefCount(retVal); } else { - /* The 'cwd' function returned an error; reset the cwd */ + /* + * The 'cwd' function returned an error; reset the cwd. + */ + FsUpdateCwd(NULL, NULL); } } @@ -2811,18 +2818,18 @@ Tcl_FSGetCwd(interp) * it. * * Results: - * See chdir() documentation. If successful, we keep a record of the + * See chdir() documentation. If successful, we keep a record of the * successful path in cwdPathPtr for subsequent calls to getcwd. * * Side effects: - * See chdir() documentation. The global cwdPathPtr may change value. + * See chdir() documentation. The global cwdPathPtr may change value. * *---------------------------------------------------------------------- */ int -Tcl_FSChdir(pathPtr) - Tcl_Obj *pathPtr; +Tcl_FSChdir( + Tcl_Obj *pathPtr) { Tcl_Filesystem *fsPtr; int retVal = -1; @@ -2851,7 +2858,7 @@ Tcl_FSChdir(pathPtr) /* * If the file can be stat'ed and is a directory and is readable, - * then we can chdir. If any of these actions fail, then + * then we can chdir. If any of these actions fail, then * 'Tcl_SetErrno()' should automatically have been called to set * an appropriate error code */ @@ -2870,22 +2877,22 @@ Tcl_FSChdir(pathPtr) } /* - * The cwd changed, or an error was thrown. If an error was thrown, we - * can just continue (and that will report the error to the user). If - * there was no error we must assume that the cwd was actually changed to - * the normalized value we calculated above, and we must therefore cache - * that information. + * The cwd changed, or an error was thrown. If an error was thrown, we can + * just continue (and that will report the error to the user). If there + * was no error we must assume that the cwd was actually changed to the + * normalized value we calculated above, and we must therefore cache that + * information. */ /* * If the filesystem in question has a getCwdProc, then the correct logic * which performs the part below is already part of the Tcl_FSGetCwd() - * call, so no need to replicate it again. This will have a side effect - * though. The private authoritative representation of the current - * working directory stored in cwdPathPtr in static memory will be - * out-of-sync with the real OS-maintained value. The first call to - * Tcl_FSGetCwd will however recalculate the private copy to match the - * OS-value so everything will work right. + * call, so no need to replicate it again. This will have a side effect + * though. The private authoritative representation of the current working + * directory stored in cwdPathPtr in static memory will be out-of-sync + * with the real OS-maintained value. The first call to Tcl_FSGetCwd will + * however recalculate the private copy to match the OS-value so + * everything will work right. * * However, if there is no getCwdProc, then we _must_ update our private * storage of the cwd, since this is the only opportunity to do that! @@ -2899,8 +2906,8 @@ Tcl_FSChdir(pathPtr) /* * Note that this normalized path may be different to what we found * above (or at least a different object), if the filesystem epoch - * changed recently. This can actually happen with scripted documents - * very easily. Therefore we ask for the normalized path again (the + * changed recently. This can actually happen with scripted documents + * very easily. Therefore we ask for the normalized path again (the * correct value will have been cached as a result of the * Tcl_FSGetFileSystemForPath call above anyway). */ @@ -2916,17 +2923,17 @@ Tcl_FSChdir(pathPtr) if (fsPtr == &tclNativeFilesystem) { /* * For the native filesystem, we keep a cache of the native - * representation of the cwd. But, we want to do that for the + * representation of the cwd. But, we want to do that for the * exact format that is returned by 'getcwd' (so that we can later * compare the two representations for equality), which might not * be exactly the same char-string as the native representation of * the fully normalized path (e.g. on Windows there's a - * forward-slash vs backslash difference). Hence we ask for this - * again here. On Unix it might actually be true that we always + * forward-slash vs backslash difference). Hence we ask for this + * again here. On Unix it might actually be true that we always * have the correct form in the native rep in which case we could * simply use: * cd = Tcl_FSGetNativePath(pathPtr); - * instead. This should be examined by someone on Unix. + * instead. This should be examined by someone on Unix. */ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); @@ -2953,43 +2960,43 @@ Tcl_FSChdir(pathPtr) * Tcl_FSLoadFile -- * * Dynamically loads a binary code file into memory and returns the - * addresses of two procedures within that file, if they are defined. - * The appropriate function for the filesystem to which pathPtr belongs - * will be called. + * addresses of two functions within that file, if they are defined. The + * appropriate function for the filesystem to which pathPtr belongs will + * be called. * * Note that the native filesystem doesn't actually assume 'pathPtr' is a - * path. Rather it assumes pathPtr is either a path or just the name + * path. Rather it assumes pathPtr is either a path or just the name * (tail) of a file which can be found somewhere in the environment's - * loadable path. This behaviour is not very compatible with virtual + * loadable path. This behaviour is not very compatible with virtual * filesystems (and has other problems documented in the load man-page), * so it is advised that full paths are always used. * * Results: - * A standard Tcl completion code. If an error occurs, an error message + * A standard Tcl completion code. If an error occurs, an error message * is left in the interp's result. * * Side effects: - * New code suddenly appears in memory. This may later be unloaded by + * New code suddenly appears in memory. This may later be unloaded by * passing the clientData to the unloadProc. * *---------------------------------------------------------------------- */ int -Tcl_FSLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, - handlePtr, unloadProcPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - Tcl_Obj *pathPtr; /* Name of the file containing the desired +Tcl_FSLoadFile( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Obj *pathPtr, /* Name of the file containing the desired * code. */ - CONST char *sym1, *sym2; /* Names of two procedures to look up in the + CONST char *sym1, CONST char *sym2, + /* Names of two functions to look up in the * file's symbol table. */ - Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; + Tcl_PackageInitProc **proc1Ptr, Tcl_PackageInitProc **proc2Ptr, /* Where to return the addresses corresponding * to sym1 and sym2. */ - Tcl_LoadHandle *handlePtr; /* Filled with token for dynamically loaded + Tcl_LoadHandle *handlePtr, /* Filled with token for dynamically loaded * file which will be passed back to * (*unloadProcPtr)() to unload the file. */ - Tcl_FSUnloadFileProc **unloadProcPtr; + Tcl_FSUnloadFileProc **unloadProcPtr) /* Filled with address of Tcl_FSUnloadFileProc * function which should be used for this * file. */ @@ -2999,21 +3006,27 @@ Tcl_FSLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, ClientData clientData; int res; - /* Initialize the arrays */ + /* + * Initialize the arrays. + */ + symbols[0] = sym1; symbols[1] = sym2; procPtrs[0] = proc1Ptr; procPtrs[1] = proc2Ptr; - /* Perform the load */ - res = TclLoadFile(interp, pathPtr, 2, symbols, procPtrs, - handlePtr, &clientData, unloadProcPtr); + /* + * Perform the load. + */ + + res = TclLoadFile(interp, pathPtr, 2, symbols, procPtrs, handlePtr, + &clientData, unloadProcPtr); /* * Due to an unfortunate mis-design in Tcl 8.4 fs, when loading a shared * library, we don't keep the loadHandle (for TclpFindSymbol) and the - * clientData (for the unloadProc) separately. In fact we effectively - * throw away the loadHandle and only use the clientData. It just so + * clientData (for the unloadProc) separately. In fact we effectively + * throw away the loadHandle and only use the clientData. It just so * happens, for the native filesystem only, that these two are identical. * * This also means that the signatures Tcl_FSUnloadFileProc and @@ -3030,318 +3043,321 @@ Tcl_FSLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, * TclLoadFile -- * * Dynamically loads a binary code file into memory and returns the - * addresses of a number of given procedures within that file, if they - * are defined. The appropriate function for the filesystem to which - * pathPtr belongs will be called. + * addresses of a number of given functions within that file, if they are + * defined. The appropriate function for the filesystem to which pathPtr + * belongs will be called. * * Note that the native filesystem doesn't actually assume 'pathPtr' is a - * path. Rather it assumes pathPtr is either a path or just the name + * path. Rather it assumes pathPtr is either a path or just the name * (tail) of a file which can be found somewhere in the environment's - * loadable path. This behaviour is not very compatible with virtual + * loadable path. This behaviour is not very compatible with virtual * filesystems (and has other problems documented in the load man-page), * so it is advised that full paths are always used. * - * This function is currently private to Tcl. It may be exported in the + * This function is currently private to Tcl. It may be exported in the * future and its interface fixed (but we should clean up the * loadHandle/clientData confusion at that time -- see the above comments - * in Tcl_FSLoadFile for details). For a public function, see + * in Tcl_FSLoadFile for details). For a public function, see * Tcl_FSLoadFile. * * Results: - * A standard Tcl completion code. If an error occurs, an error message + * A standard Tcl completion code. If an error occurs, an error message * is left in the interp's result. * * Side effects: - * New code suddenly appears in memory. This may later be unloaded by + * New code suddenly appears in memory. This may later be unloaded by * passing the clientData to the unloadProc. * *---------------------------------------------------------------------- */ int -TclLoadFile(interp, pathPtr, symc, symbols, procPtrs, - handlePtr, clientDataPtr, unloadProcPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - Tcl_Obj *pathPtr; /* Name of the file containing the desired +TclLoadFile( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Obj *pathPtr, /* Name of the file containing the desired * code. */ - int symc; /* Number of symbols/procPtrs in the next two + int symc, /* Number of symbols/procPtrs in the next two * arrays. */ - CONST char *symbols[]; /* Names of procedures to look up in the - * file's symbol table. */ - Tcl_PackageInitProc **procPtrs[]; + CONST char *symbols[], /* Names of functions to look up in the file's + * symbol table. */ + Tcl_PackageInitProc **procPtrs[], /* Where to return the addresses corresponding - * to symbols[]. */ - Tcl_LoadHandle *handlePtr; /* Filled with token for shared library + * to symbols[]. */ + Tcl_LoadHandle *handlePtr, /* Filled with token for shared library * information which can be used in * TclpFindSymbol. */ - ClientData *clientDataPtr; /* Filled with token for dynamically loaded + ClientData *clientDataPtr, /* Filled with token for dynamically loaded * file which will be passed back to * (*unloadProcPtr)() to unload the file. */ - Tcl_FSUnloadFileProc **unloadProcPtr; + Tcl_FSUnloadFileProc **unloadProcPtr) /* Filled with address of Tcl_FSUnloadFileProc * function which should be used for this * file. */ { Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - if (fsPtr != NULL) { - Tcl_FSLoadFileProc *proc = fsPtr->loadFileProc; - Tcl_Filesystem *copyFsPtr; - Tcl_Obj *copyToPtr; + Tcl_FSLoadFileProc *proc; + Tcl_Filesystem *copyFsPtr; + Tcl_Obj *copyToPtr; + Tcl_LoadHandle newLoadHandle = NULL; + ClientData newClientData = NULL; + Tcl_FSUnloadFileProc *newUnloadProcPtr = NULL; + FsDivertLoad *tvdlPtr; + int retVal; - if (proc != NULL) { - int retVal = (*proc)(interp, pathPtr, handlePtr, unloadProcPtr); - if (retVal == TCL_OK) { - int i; - if (*handlePtr == NULL) { - return TCL_ERROR; - } - for (i=0 ; i<symc ; i++) { - if (symbols[i] != NULL) { - *procPtrs[i] = TclpFindSymbol(interp, *handlePtr, - symbols[i]); - } - } - - /* - * Copy this across, since both are equal for the native fs. - */ + if (fsPtr == NULL) { + Tcl_SetErrno(ENOENT); + return TCL_ERROR; + } - *clientDataPtr = (ClientData)*handlePtr; - Tcl_ResetResult(interp); - return TCL_OK; - } - if (Tcl_GetErrno() != EXDEV) { - return retVal; + proc = fsPtr->loadFileProc; + if (proc != NULL) { + int retVal = (*proc)(interp, pathPtr, handlePtr, unloadProcPtr); + if (retVal == TCL_OK) { + if (*handlePtr == NULL) { + return TCL_ERROR; } - } - /* - * The filesystem doesn't support 'load', so we fall back on the - * following technique: - * - * First check if it is readable -- and exists! - */ + /* + * Copy this across, since both are equal for the native fs. + */ - if (Tcl_FSAccess(pathPtr, R_OK) != 0) { - Tcl_AppendResult(interp, "couldn't load library \"", - Tcl_GetString(pathPtr), "\": ", - Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; + *clientDataPtr = (ClientData)*handlePtr; + Tcl_ResetResult(interp); + goto resolveSymbols; + } + if (Tcl_GetErrno() != EXDEV) { + return retVal; } + } + + /* + * The filesystem doesn't support 'load', so we fall back on the following + * technique: + * + * First check if it is readable -- and exists! + */ + + if (Tcl_FSAccess(pathPtr, R_OK) != 0) { + Tcl_AppendResult(interp, "couldn't load library \"", + Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + return TCL_ERROR; + } #ifdef TCL_LOAD_FROM_MEMORY - /* - * The platform supports loading code from memory, so ask for a buffer - * of the appropriate size, read the file into it and load the code - * from the buffer: - */ + /* + * The platform supports loading code from memory, so ask for a buffer of + * the appropriate size, read the file into it and load the code from the + * buffer: + */ - do { - int ret, size; - void *buffer; - Tcl_StatBuf statBuf; - Tcl_Channel data; + { + int ret, size; + void *buffer; + Tcl_StatBuf statBuf; + Tcl_Channel data; - ret = Tcl_FSStat(pathPtr, &statBuf); - if (ret < 0) { - break; - } - size = (int) statBuf.st_size; + ret = Tcl_FSStat(pathPtr, &statBuf); + if (ret < 0) { + goto mustCopyToTempAnyway; + } + size = (int) statBuf.st_size; - /* - * Tcl_Read takes an int: check that file size isn't wide. - */ + /* + * Tcl_Read takes an int: check that file size isn't wide. + */ - if (size != (Tcl_WideInt) statBuf.st_size) { - break; - } - data = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0666); - if (!data) { - break; - } - buffer = TclpLoadMemoryGetBuffer(interp, size); - if (!buffer) { - Tcl_Close(interp, data); - break; - } - Tcl_SetChannelOption(interp, data, "-translation", "binary"); - ret = Tcl_Read(data, buffer, size); + if (size != (Tcl_WideInt) statBuf.st_size) { + goto mustCopyToTempAnyway; + } + data = Tcl_FSOpenFileChannel(interp, pathPtr, "rb", 0666); + if (!data) { + goto mustCopyToTempAnyway; + } + buffer = TclpLoadMemoryGetBuffer(interp, size); + if (!buffer) { Tcl_Close(interp, data); - ret = TclpLoadMemory(interp, buffer, size, ret, handlePtr, - unloadProcPtr); - if (ret == TCL_OK) { - int i; - if (*handlePtr == NULL) { - break; - } - for (i = 0;i < symc;i++) { - if (symbols[i] != NULL) { - *procPtrs[i] = TclpFindSymbol(interp, *handlePtr, - symbols[i]); - } - } - *clientDataPtr = (ClientData) *handlePtr; - return TCL_OK; - } - } while (0); - Tcl_ResetResult(interp); + goto mustCopyToTempAnyway; + } + ret = Tcl_Read(data, buffer, size); + Tcl_Close(interp, data); + ret = TclpLoadMemory(interp, buffer, size, ret, handlePtr, + unloadProcPtr); + if (ret == TCL_OK && *handlePtr != NULL) { + *clientDataPtr = (ClientData) *handlePtr; + goto resolveSymbols; + } + } + + mustCopyToTempAnyway: + Tcl_ResetResult(interp); #endif + /* + * Get a temporary filename to use, first to copy the file into, and then + * to load. + */ + + copyToPtr = TclpTempFileName(); + if (copyToPtr == NULL) { + Tcl_AppendResult(interp, "couldn't create temporary file: ", + Tcl_PosixError(interp), NULL); + return TCL_ERROR; + } + Tcl_IncrRefCount(copyToPtr); + + copyFsPtr = Tcl_FSGetFileSystemForPath(copyToPtr); + if ((copyFsPtr == NULL) || (copyFsPtr == fsPtr)) { /* - * Get a temporary filename to use, first to copy the file into, and - * then to load. + * We already know we can't use Tcl_FSLoadFile from this filesystem, + * and we must avoid a possible infinite loop. Try to delete the file + * we probably created, and then exit. */ - copyToPtr = TclpTempFileName(); - if (copyToPtr == NULL) { - Tcl_AppendResult(interp, "couldn't create temporary file: ", - Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; - } - Tcl_IncrRefCount(copyToPtr); - - copyFsPtr = Tcl_FSGetFileSystemForPath(copyToPtr); - if ((copyFsPtr == NULL) || (copyFsPtr == fsPtr)) { - /* - * We already know we can't use Tcl_FSLoadFile from this - * filesystem, and we must avoid a possible infinite loop. Try to - * delete the file we probably created, and then exit. - */ + Tcl_FSDeleteFile(copyToPtr); + Tcl_DecrRefCount(copyToPtr); + Tcl_AppendResult(interp, "couldn't load from current filesystem",NULL); + return TCL_ERROR; + } - Tcl_FSDeleteFile(copyToPtr); - Tcl_DecrRefCount(copyToPtr); - Tcl_AppendResult(interp, "couldn't load from current filesystem", - (char *) NULL); - return TCL_ERROR; - } + if (TclCrossFilesystemCopy(interp, pathPtr, copyToPtr) != TCL_OK) { + /* + * Cross-platform copy failed. + */ - if (TclCrossFilesystemCopy(interp, pathPtr, copyToPtr) == TCL_OK) { - Tcl_LoadHandle newLoadHandle = NULL; - ClientData newClientData = NULL; - Tcl_FSUnloadFileProc *newUnloadProcPtr = NULL; - FsDivertLoad *tvdlPtr; - int retVal; + Tcl_FSDeleteFile(copyToPtr); + Tcl_DecrRefCount(copyToPtr); + return TCL_ERROR; + } #if !defined(__WIN32__) - /* - * Do we need to set appropriate permissions on the file? This - * may be required on some systems. On Unix we could loop over - * the file attributes, and set any that are called "-permissions" - * to 0700. However, we just do this directly, like this: - */ + /* + * Do we need to set appropriate permissions on the file? This may be + * required on some systems. On Unix we could loop over the file + * attributes, and set any that are called "-permissions" to 0700. However + * we just do this directly, like this: + */ - int index; - Tcl_Obj* perm = Tcl_NewStringObj("0700",-1); - Tcl_IncrRefCount(perm); - if (TclFSFileAttrIndex(copyToPtr, "-permissions", - &index) == TCL_OK) { - Tcl_FSFileAttrsSet(NULL, index, copyToPtr, perm); - } - Tcl_DecrRefCount(perm); + { + int index; + Tcl_Obj* perm = Tcl_NewStringObj("0700",-1); + + Tcl_IncrRefCount(perm); + if (TclFSFileAttrIndex(copyToPtr, "-permissions", &index) == TCL_OK) { + Tcl_FSFileAttrsSet(NULL, index, copyToPtr, perm); + } + Tcl_DecrRefCount(perm); + } #endif - /* - * We need to reset the result now, because the cross- filesystem - * copy may have stored the number of bytes in the result. - */ + /* + * We need to reset the result now, because the cross-filesystem copy may + * have stored the number of bytes in the result. + */ - Tcl_ResetResult(interp); + Tcl_ResetResult(interp); - retVal = TclLoadFile(interp, copyToPtr, symc, symbols, procPtrs, - &newLoadHandle, &newClientData, &newUnloadProcPtr); - if (retVal != TCL_OK) { - /* The file didn't load successfully */ - Tcl_FSDeleteFile(copyToPtr); - Tcl_DecrRefCount(copyToPtr); - return retVal; - } + retVal = TclLoadFile(interp, copyToPtr, symc, symbols, procPtrs, + &newLoadHandle, &newClientData, &newUnloadProcPtr); + if (retVal != TCL_OK) { + /* + * The file didn't load successfully. + */ - /* - * Try to delete the file immediately - this is possible in some - * OSes, and avoids any worries about leaving the copy laying - * around on exit. - */ + Tcl_FSDeleteFile(copyToPtr); + Tcl_DecrRefCount(copyToPtr); + return retVal; + } - if (Tcl_FSDeleteFile(copyToPtr) == TCL_OK) { - Tcl_DecrRefCount(copyToPtr); + /* + * Try to delete the file immediately - this is possible in some OSes, and + * avoids any worries about leaving the copy laying around on exit. + */ - /* - * We tell our caller about the real shared library which was - * loaded. Note that this does mean that the package list - * maintained by 'load' will store the original (vfs) path - * alongside the temporary load handle and unload proc ptr. - */ + if (Tcl_FSDeleteFile(copyToPtr) == TCL_OK) { + Tcl_DecrRefCount(copyToPtr); - (*handlePtr) = newLoadHandle; - (*clientDataPtr) = newClientData; - (*unloadProcPtr) = newUnloadProcPtr; - Tcl_ResetResult(interp); - return TCL_OK; - } + /* + * We tell our caller about the real shared library which was loaded. + * Note that this does mean that the package list maintained by 'load' + * will store the original (vfs) path alongside the temporary load + * handle and unload proc ptr. + */ - /* - * When we unload this file, we need to divert the unloading so we - * can unload and cleanup the temporary file correctly. - */ + (*handlePtr) = newLoadHandle; + (*clientDataPtr) = newClientData; + (*unloadProcPtr) = newUnloadProcPtr; + Tcl_ResetResult(interp); + return TCL_OK; + } - tvdlPtr = (FsDivertLoad *) ckalloc(sizeof(FsDivertLoad)); + /* + * When we unload this file, we need to divert the unloading so we can + * unload and cleanup the temporary file correctly. + */ - /* - * Remember three pieces of information. This allows us to - * cleanup the diverted load completely, on platforms which allow - * proper unloading of code. - */ + tvdlPtr = (FsDivertLoad *) ckalloc(sizeof(FsDivertLoad)); - tvdlPtr->loadHandle = newLoadHandle; - tvdlPtr->unloadProcPtr = newUnloadProcPtr; + /* + * Remember three pieces of information. This allows us to cleanup the + * diverted load completely, on platforms which allow proper unloading of + * code. + */ - if (copyFsPtr != &tclNativeFilesystem) { - /* copyToPtr is already incremented for this reference */ - tvdlPtr->divertedFile = copyToPtr; + tvdlPtr->loadHandle = newLoadHandle; + tvdlPtr->unloadProcPtr = newUnloadProcPtr; - /* - * This is the filesystem we loaded it into. Since we have a - * reference to 'copyToPtr', we already have a refCount on - * this filesystem, so we don't need to worry about it - * disappearing on us. - */ + if (copyFsPtr != &tclNativeFilesystem) { + /* + * copyToPtr is already incremented for this reference. + */ - tvdlPtr->divertedFilesystem = copyFsPtr; - tvdlPtr->divertedFileNativeRep = NULL; - } else { - /* We need the native rep */ - tvdlPtr->divertedFileNativeRep = TclNativeDupInternalRep( - Tcl_FSGetInternalRep(copyToPtr, copyFsPtr)); + tvdlPtr->divertedFile = copyToPtr; - /* - * We don't need or want references to the copied Tcl_Obj or - * the filesystem if it is the native one. - */ + /* + * This is the filesystem we loaded it into. Since we have a reference + * to 'copyToPtr', we already have a refCount on this filesystem, so + * we don't need to worry about it disappearing on us. + */ - tvdlPtr->divertedFile = NULL; - tvdlPtr->divertedFilesystem = NULL; - Tcl_DecrRefCount(copyToPtr); - } + tvdlPtr->divertedFilesystem = copyFsPtr; + tvdlPtr->divertedFileNativeRep = NULL; + } else { + /* + * We need the native rep. + */ - copyToPtr = NULL; - (*handlePtr) = newLoadHandle; - (*clientDataPtr) = (ClientData) tvdlPtr; - (*unloadProcPtr) = &FSUnloadTempFile; - Tcl_ResetResult(interp); - return retVal; + tvdlPtr->divertedFileNativeRep = TclNativeDupInternalRep( + Tcl_FSGetInternalRep(copyToPtr, copyFsPtr)); - } else { - /* - * Cross-platform copy failed. - */ + /* + * We don't need or want references to the copied Tcl_Obj or the + * filesystem if it is the native one. + */ - Tcl_FSDeleteFile(copyToPtr); - Tcl_DecrRefCount(copyToPtr); - return TCL_ERROR; + tvdlPtr->divertedFile = NULL; + tvdlPtr->divertedFilesystem = NULL; + Tcl_DecrRefCount(copyToPtr); + } + + copyToPtr = NULL; + (*handlePtr) = newLoadHandle; + (*clientDataPtr) = (ClientData) tvdlPtr; + (*unloadProcPtr) = &FSUnloadTempFile; + + Tcl_ResetResult(interp); + return retVal; + + resolveSymbols: + { + int i; + + for (i=0 ; i<symc ; i++) { + if (symbols[i] != NULL) { + *procPtrs[i] = TclpFindSymbol(interp, *handlePtr, symbols[i]); + } } } - Tcl_SetErrno(ENOENT); - return TCL_ERROR; + return TCL_OK; } /* * This function used to be in the platform specific directories, but it has @@ -3349,20 +3365,20 @@ TclLoadFile(interp, pathPtr, symc, symbols, procPtrs, */ int -TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, - clientDataPtr, unloadProcPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - Tcl_Obj *pathPtr; /* Name of the file containing the desired +TclpLoadFile( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Obj *pathPtr, /* Name of the file containing the desired * code (UTF-8). */ - CONST char *sym1, *sym2; /* Names of two procedures to look up in the + CONST char *sym1, CONST char *sym2, + /* Names of two functions to look up in the * file's symbol table. */ - Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; + Tcl_PackageInitProc **proc1Ptr, Tcl_PackageInitProc **proc2Ptr, /* Where to return the addresses corresponding * to sym1 and sym2. */ - ClientData *clientDataPtr; /* Filled with token for dynamically loaded + ClientData *clientDataPtr, /* Filled with token for dynamically loaded * file which will be passed back to * (*unloadProcPtr)() to unload the file. */ - Tcl_FSUnloadFileProc **unloadProcPtr; + Tcl_FSUnloadFileProc **unloadProcPtr) /* Filled with address of Tcl_FSUnloadFileProc * function which should be used for this * file. */ @@ -3380,7 +3396,7 @@ TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, return TCL_ERROR; } - *clientDataPtr = (ClientData)handle; + *clientDataPtr = (ClientData) handle; *proc1Ptr = TclpFindSymbol(interp, handle, sym1); *proc2Ptr = TclpFindSymbol(interp, handle, sym2); @@ -3393,7 +3409,7 @@ TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, * FSUnloadTempFile -- * * This function is called when we loaded a library of code via an - * intermediate temporary file. This function ensures the library is + * intermediate temporary file. This function ensures the library is * correctly unloaded and the temporary file is correctly deleted. * * Results: @@ -3405,25 +3421,28 @@ TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, * *--------------------------------------------------------------------------- */ + static void -FSUnloadTempFile(loadHandle) - Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call to - * Tcl_FSLoadFile(). The loadHandle is a token - * that represents the loaded file. */ +FSUnloadTempFile( + Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to + * Tcl_FSLoadFile(). The loadHandle is a token + * that represents the loaded file. */ { - FsDivertLoad *tvdlPtr = (FsDivertLoad*)loadHandle; + FsDivertLoad *tvdlPtr = (FsDivertLoad *) loadHandle; /* * This test should never trigger, since we give the client data in the * function above. */ - if (tvdlPtr == NULL) { return; } + if (tvdlPtr == NULL) { + return; + } /* * Call the real 'unloadfile' proc we actually used. It is very important * that we call this first, so that the shared library is actually - * unloaded by the OS. Otherwise, the following 'delete' may well fail + * unloaded by the OS. Otherwise, the following 'delete' may well fail * because the shared library is still in use. */ @@ -3443,7 +3462,7 @@ FSUnloadTempFile(loadHandle) } else { /* - * Remove the temporary file we created. Note, we may crash here + * Remove the temporary file we created. Note, we may crash here * because encodings have been taken down already. */ @@ -3467,7 +3486,7 @@ FSUnloadTempFile(loadHandle) } /* - * And free up the allocations. This will also of course remove a + * And free up the allocations. This will also of course remove a * refCount from the Tcl_Filesystem to which this file belongs, which * could then free up the filesystem if we are exiting. */ @@ -3484,18 +3503,18 @@ FSUnloadTempFile(loadHandle) * Tcl_FSLink -- * * This function replaces the library version of readlink() and can also - * be used to make links. The appropriate function for the filesystem to + * be used to make links. The appropriate function for the filesystem to * which pathPtr belongs will be called. * * Results: * If toPtr is NULL, then the result is a Tcl_Obj specifying the contents * of the symbolic link given by 'pathPtr', or NULL if the symbolic link - * could not be read. The result is owned by the caller, which should + * could not be read. The result is owned by the caller, which should * call Tcl_DecrRefCount when the result is no longer needed. * * If toPtr is non-NULL, then the result is toPtr if the link action was - * successful, or NULL if not. In this case the result has no additional - * reference count, and need not be freed. The actual action to perform + * successful, or NULL if not. In this case the result has no additional + * reference count, and need not be freed. The actual action to perform * is given by the 'linkAction' flags, which is an or'd combination of: * * TCL_CREATE_SYMBOLIC_LINK @@ -3506,20 +3525,22 @@ FSUnloadTempFile(loadHandle) * is in the same FS as pathPtr. * * Side effects: - * See readlink() documentation. A new filesystem link object may appear + * See readlink() documentation. A new filesystem link object may appear. * *--------------------------------------------------------------------------- */ Tcl_Obj * -Tcl_FSLink(pathPtr, toPtr, linkAction) - Tcl_Obj *pathPtr; /* Path of file to readlink or link */ - Tcl_Obj *toPtr; /* NULL or path to be linked to */ - int linkAction; /* Action to perform */ +Tcl_FSLink( + Tcl_Obj *pathPtr, /* Path of file to readlink or link */ + Tcl_Obj *toPtr, /* NULL or path to be linked to */ + int linkAction) /* Action to perform */ { Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { Tcl_FSLinkProc *proc = fsPtr->linkProc; + if (proc != NULL) { return (*proc)(pathPtr, toPtr, linkAction); } @@ -3527,10 +3548,10 @@ Tcl_FSLink(pathPtr, toPtr, linkAction) /* * If S_IFLNK isn't defined it means that the machine doesn't support - * symbolic links, so the file can't possibly be a symbolic link. - * Generate an EINVAL error, which is what happens on machines that do - * support symbolic links when you invoke readlink on a file that isn't a - * symbolic link. + * symbolic links, so the file can't possibly be a symbolic link. Generate + * an EINVAL error, which is what happens on machines that do support + * symbolic links when you invoke readlink on a file that isn't a symbolic + * link. */ #ifndef S_IFLNK @@ -3546,15 +3567,15 @@ Tcl_FSLink(pathPtr, toPtr, linkAction) * * Tcl_FSListVolumes -- * - * Lists the currently mounted volumes. The chain of functions that have + * Lists the currently mounted volumes. The chain of functions that have * been "inserted" into the filesystem will be called in succession; each * may return a list of volumes, all of which are added to the result * until all mounted file systems are listed. * * Notice that we assume the lists returned by each filesystem (if non - * NULL) have been given a refCount for us already. However, we are NOT + * NULL) have been given a refCount for us already. However, we are NOT * allowed to hang on to the list itself (it belongs to the filesystem we - * called). Therefore we quite naturally add its contents to the result + * called). Therefore we quite naturally add its contents to the result * we are building, and then decrement the refCount. * * Results: @@ -3573,8 +3594,8 @@ Tcl_FSListVolumes(void) Tcl_Obj *resultPtr = Tcl_NewObj(); /* - * Call each of the "listVolumes" function in succession. A non-NULL - * return value indicates the particular function has succeeded. We call + * Call each of the "listVolumes" function in succession. A non-NULL + * return value indicates the particular function has succeeded. We call * all the functions registered, since we want a list of all drives from * all filesystems. */ @@ -3613,10 +3634,10 @@ Tcl_FSListVolumes(void) *--------------------------------------------------------------------------- */ -static Tcl_Obj* -FsListMounts(pathPtr, pattern) - Tcl_Obj *pathPtr; /* Contains path to directory to search. */ - CONST char *pattern; /* Pattern to match against. */ +static Tcl_Obj * +FsListMounts( + Tcl_Obj *pathPtr, /* Contains path to directory to search. */ + CONST char *pattern) /* Pattern to match against. */ { FilesystemRecord *fsRecPtr; Tcl_GlobTypeData mountsOnly = { TCL_GLOB_TYPE_MOUNT, 0, NULL, NULL }; @@ -3624,8 +3645,8 @@ FsListMounts(pathPtr, pattern) /* * Call each of the "matchInDirectory" functions in succession, with the - * specific type information 'mountsOnly'. A non-NULL return value - * indicates the particular function has succeeded. We call all the + * specific type information 'mountsOnly'. A non-NULL return value + * indicates the particular function has succeeded. We call all the * functions registered, since we want a list from each filesystems. */ @@ -3657,7 +3678,7 @@ FsListMounts(pathPtr, pattern) * an element. * * Results: - * Returns list object with refCount of zero. If the passed in lenPtr is + * Returns list object with refCount of zero. If the passed in lenPtr is * non-NULL, we use it to return the number of elements in the returned * list. * @@ -3667,10 +3688,10 @@ FsListMounts(pathPtr, pattern) *--------------------------------------------------------------------------- */ -Tcl_Obj* -Tcl_FSSplitPath(pathPtr, lenPtr) - Tcl_Obj *pathPtr; /* Path to split. */ - int *lenPtr; /* int to store number of path elements. */ +Tcl_Obj * +Tcl_FSSplitPath( + Tcl_Obj *pathPtr, /* Path to split. */ + int *lenPtr) /* int to store number of path elements. */ { Tcl_Obj *result = NULL; /* Needed only to prevent gcc warnings. */ Tcl_Filesystem *fsPtr; @@ -3705,7 +3726,7 @@ Tcl_FSSplitPath(pathPtr, lenPtr) } /* - * Place the drive name as first element of the result list. The drive + * Place the drive name as first element of the result list. The drive * name may contain strange characters, like colons and multiple forward * slashes (for example 'ftp://' is a valid vfs drive name) */ @@ -3753,11 +3774,11 @@ Tcl_FSSplitPath(pathPtr, lenPtr) } /* Simple helper function */ -Tcl_Obj* -TclFSInternalToNormalized(fromFilesystem, clientData, fsRecPtrPtr) - Tcl_Filesystem *fromFilesystem; - ClientData clientData; - FilesystemRecord **fsRecPtrPtr; +Tcl_Obj * +TclFSInternalToNormalized( + Tcl_Filesystem *fromFilesystem, + ClientData clientData, + FilesystemRecord **fsRecPtrPtr) { FilesystemRecord *fsRecPtr = FsGetFirstFilesystem(); @@ -3786,7 +3807,7 @@ TclFSInternalToNormalized(fromFilesystem, clientData, fsRecPtrPtr) * * Results: * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or - * TCL_PATH_VOLUME_RELATIVE. The filesystem reference will be set if and + * TCL_PATH_VOLUME_RELATIVE. The filesystem reference will be set if and * only if it is non-NULL and the function's return value is * TCL_PATH_ABSOLUTE. * @@ -3797,19 +3818,20 @@ TclFSInternalToNormalized(fromFilesystem, clientData, fsRecPtrPtr) */ Tcl_PathType -TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef) - Tcl_Obj *pathPtr; /* Path to determine type for */ - Tcl_Filesystem **filesystemPtrPtr; /* If absolute path and this is not - * NULL, then set to the filesystem - * which claims this path. */ - int *driveNameLengthPtr; /* If the path is absolute, and this - * is non-NULL, then set to the length - * of the driveName. */ - Tcl_Obj **driveNameRef; /* If the path is absolute, and this - * is non-NULL, then set to the name - * of the drive, network-volume which - * contains the path, already with a - * refCount for the caller. */ +TclGetPathType( + Tcl_Obj *pathPtr, /* Path to determine type for */ + Tcl_Filesystem **filesystemPtrPtr, + /* If absolute path and this is not NULL, then + * set to the filesystem which claims this + * path. */ + int *driveNameLengthPtr, /* If the path is absolute, and this is + * non-NULL, then set to the length of the + * driveName. */ + Tcl_Obj **driveNameRef) /* If the path is absolute, and this is + * non-NULL, then set to the name of the + * drive, network-volume which contains the + * path, already with a refCount for the + * caller. */ { int pathLen; char *path; @@ -3835,14 +3857,14 @@ TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef) * * TclFSNonnativePathType -- * - * Helper function used by TclGetPathType. Its purpose is to check + * Helper function used by TclGetPathType. Its purpose is to check * whether the given path starts with a string which corresponds to a - * file volume in any registered filesystem except the native one. For + * file volume in any registered filesystem except the native one. For * speed and historical reasons the native filesystem has special * hard-coded checks dotted here and there in the filesystem code. * * Results: - * Returns one of TCL_PATH_ABSOLUTE or TCL_PATH_RELATIVE. The filesystem + * Returns one of TCL_PATH_ABSOLUTE or TCL_PATH_RELATIVE. The filesystem * reference will be set if and only if it is non-NULL and the function's * return value is TCL_PATH_ABSOLUTE. * @@ -3853,21 +3875,21 @@ TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef) */ Tcl_PathType -TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, driveNameLengthPtr, - driveNameRef) - CONST char *path; /* Path to determine type for */ - int pathLen; /* Length of the path */ - Tcl_Filesystem **filesystemPtrPtr; /* If absolute path and this is not - * NULL, then set to the filesystem - * which claims this path. */ - int *driveNameLengthPtr; /* If the path is absolute, and this - * is non-NULL, then set to the length - * of the driveName. */ - Tcl_Obj **driveNameRef; /* If the path is absolute, and this - * is non-NULL, then set to the name - * of the drive, network-volume which - * contains the path, already with a - * refCount for the caller. */ +TclFSNonnativePathType( + CONST char *path, /* Path to determine type for */ + int pathLen, /* Length of the path */ + Tcl_Filesystem **filesystemPtrPtr, + /* If absolute path and this is not NULL, then + * set to the filesystem which claims this + * path. */ + int *driveNameLengthPtr, /* If the path is absolute, and this is + * non-NULL, then set to the length of the + * driveName. */ + Tcl_Obj **driveNameRef) /* If the path is absolute, and this is + * non-NULL, then set to the name of the + * drive, network-volume which contains the + * path, already with a refCount for the + * caller. */ { FilesystemRecord *fsRecPtr; Tcl_PathType type = TCL_PATH_RELATIVE; @@ -3888,7 +3910,7 @@ TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, driveNameLengthPtr, * is because some of the tests artificially change the current * platform (between win, unix) but the list of volumes we get by * calling (*proc) will reflect the current (real) platform only and - * this may cause some tests to fail. In particular, on unix '/' will + * this may cause some tests to fail. In particular, on unix '/' will * match the beginning of certain absolute Windows paths starting '//' * and those tests will go wrong. * @@ -3904,12 +3926,13 @@ TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, driveNameLengthPtr, if ((fsRecPtr->fsPtr != &tclNativeFilesystem) && (proc != NULL)) { int numVolumes; Tcl_Obj *thisFsVolumes = (*proc)(); + if (thisFsVolumes != NULL) { - if (Tcl_ListObjLength(NULL, thisFsVolumes, - &numVolumes) != TCL_OK) { + if (Tcl_ListObjLength(NULL, thisFsVolumes, &numVolumes) + != TCL_OK) { /* * This is VERY bad; the Tcl_FSListVolumesProc didn't - * return a valid list. Set numVolumes to -1 so that we + * return a valid list. Set numVolumes to -1 so that we * skip the while loop below and just return with the * current value of 'type'. * @@ -3947,7 +3970,9 @@ TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, driveNameLengthPtr, } Tcl_DecrRefCount(thisFsVolumes); if (type == TCL_PATH_ABSOLUTE) { - /* We don't need to examine any more filesystems */ + /* + * We don't need to examine any more filesystems. + */ break; } } @@ -3963,7 +3988,7 @@ TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, driveNameLengthPtr, * Tcl_FSRenameFile -- * * If the two paths given belong to the same filesystem, we call that - * filesystems rename function. Otherwise we simply return the posix + * filesystems rename function. Otherwise we simply return the POSIX * error 'EXDEV', and -1. * * Results: @@ -3976,10 +4001,10 @@ TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, driveNameLengthPtr, */ int -Tcl_FSRenameFile(srcPathPtr, destPathPtr) - Tcl_Obj* srcPathPtr; /* Pathname of file or dir to be renamed +Tcl_FSRenameFile( + Tcl_Obj* srcPathPtr, /* Pathname of file or dir to be renamed * (UTF-8). */ - Tcl_Obj *destPathPtr; /* New pathname of file or directory + Tcl_Obj *destPathPtr) /* New pathname of file or directory * (UTF-8). */ { int retVal = -1; @@ -3987,10 +4012,10 @@ Tcl_FSRenameFile(srcPathPtr, destPathPtr) fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr); fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr); - if (fsPtr == fsPtr2 && fsPtr != NULL) { + if ((fsPtr == fsPtr2) && (fsPtr != NULL)) { Tcl_FSRenameFileProc *proc = fsPtr->renameFileProc; if (proc != NULL) { - retVal = (*proc)(srcPathPtr, destPathPtr); + retVal = (*proc)(srcPathPtr, destPathPtr); } } if (retVal == -1) { @@ -4005,8 +4030,8 @@ Tcl_FSRenameFile(srcPathPtr, destPathPtr) * Tcl_FSCopyFile -- * * If the two paths given belong to the same filesystem, we call that - * filesystem's copy function. Otherwise we simply return the posix - * error 'EXDEV', and -1. + * filesystem's copy function. Otherwise we simply return the POSIX error + * 'EXDEV', and -1. * * Note that in the native filesystems, 'copyFileProc' is defined to copy * soft links (i.e. it copies the links themselves, not the things they @@ -4022,9 +4047,9 @@ Tcl_FSRenameFile(srcPathPtr, destPathPtr) */ int -Tcl_FSCopyFile(srcPathPtr, destPathPtr) - Tcl_Obj* srcPathPtr; /* Pathname of file to be copied (UTF-8). */ - Tcl_Obj *destPathPtr; /* Pathname of file to copy to (UTF-8). */ +Tcl_FSCopyFile( + Tcl_Obj *srcPathPtr, /* Pathname of file to be copied (UTF-8). */ + Tcl_Obj *destPathPtr) /* Pathname of file to copy to (UTF-8). */ { int retVal = -1; Tcl_Filesystem *fsPtr, *fsPtr2; @@ -4049,7 +4074,7 @@ Tcl_FSCopyFile(srcPathPtr, destPathPtr) * TclCrossFilesystemCopy -- * * Helper for above function, and for Tcl_FSLoadFile, to copy files from - * one filesystem to another. This function will overwrite the target + * one filesystem to another. This function will overwrite the target * file if it already exists. * * Results: @@ -4061,64 +4086,62 @@ Tcl_FSCopyFile(srcPathPtr, destPathPtr) *--------------------------------------------------------------------------- */ int -TclCrossFilesystemCopy(interp, source, target) - Tcl_Interp *interp; /* For error messages */ - Tcl_Obj *source; /* Pathname of file to be copied (UTF-8). */ - Tcl_Obj *target; /* Pathname of file to copy to (UTF-8). */ +TclCrossFilesystemCopy( + Tcl_Interp *interp, /* For error messages */ + Tcl_Obj *source, /* Pathname of file to be copied (UTF-8). */ + Tcl_Obj *target) /* Pathname of file to copy to (UTF-8). */ { int result = TCL_ERROR; int prot = 0666; + Tcl_Channel in, out; + Tcl_StatBuf sourceStatBuf; + struct utimbuf tval; - Tcl_Channel out = Tcl_FSOpenFileChannel(interp, target, "w", prot); - if (out != NULL) { + out = Tcl_FSOpenFileChannel(interp, target, "wb", prot); + if (out == NULL) { /* - * It looks like we can copy it over. + * It looks like we cannot copy it over. Bail out... */ + goto done; + } - Tcl_Channel in = Tcl_FSOpenFileChannel(interp, source, "r", prot); - - if (in == NULL) { - /* - * This is very strange, we checked this above - */ - - Tcl_Close(interp, out); - - } else { - Tcl_StatBuf sourceStatBuf; - struct utimbuf tval; + in = Tcl_FSOpenFileChannel(interp, source, "rb", prot); + if (in == NULL) { + /* + * This is very strange, caller should have checked this... + */ - /* - * Copy it synchronously. We might wish to add an asynchronous - * option to support vfs's which are slow (e.g. network sockets). - */ + Tcl_Close(interp, out); + goto done; + } - Tcl_SetChannelOption(interp, in, "-translation", "binary"); - Tcl_SetChannelOption(interp, out, "-translation", "binary"); + /* + * Copy it synchronously. We might wish to add an asynchronous option to + * support vfs's which are slow (e.g. network sockets). + */ - if (TclCopyChannel(interp, in, out, -1, NULL) == TCL_OK) { - result = TCL_OK; - } + if (TclCopyChannel(interp, in, out, -1, NULL) == TCL_OK) { + result = TCL_OK; + } - /* - * If the copy failed, assume that copy channel left a good error - * message. - */ + /* + * If the copy failed, assume that copy channel left a good error message. + */ - Tcl_Close(interp, in); - Tcl_Close(interp, out); + Tcl_Close(interp, in); + Tcl_Close(interp, out); - /* - * Set modification date of copied file. - */ + /* + * Set modification date of copied file. + */ - if (Tcl_FSLstat(source, &sourceStatBuf) == 0) { - tval.actime = sourceStatBuf.st_atime; - tval.modtime = sourceStatBuf.st_mtime; - Tcl_FSUtime(target, &tval); - } - } + if (Tcl_FSLstat(source, &sourceStatBuf) == 0) { + tval.actime = sourceStatBuf.st_atime; + tval.modtime = sourceStatBuf.st_mtime; + Tcl_FSUtime(target, &tval); } + + done: return result; } @@ -4140,8 +4163,8 @@ TclCrossFilesystemCopy(interp, source, target) */ int -Tcl_FSDeleteFile(pathPtr) - Tcl_Obj *pathPtr; /* Pathname of file to be removed (UTF-8). */ +Tcl_FSDeleteFile( + Tcl_Obj *pathPtr) /* Pathname of file to be removed (UTF-8). */ { Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL) { @@ -4172,8 +4195,8 @@ Tcl_FSDeleteFile(pathPtr) */ int -Tcl_FSCreateDirectory(pathPtr) - Tcl_Obj *pathPtr; /* Pathname of directory to create (UTF-8). */ +Tcl_FSCreateDirectory( + Tcl_Obj *pathPtr) /* Pathname of directory to create (UTF-8). */ { Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL) { @@ -4192,8 +4215,8 @@ Tcl_FSCreateDirectory(pathPtr) * Tcl_FSCopyDirectory -- * * If the two paths given belong to the same filesystem, we call that - * filesystems copy-directory function. Otherwise we simply return the - * posix error 'EXDEV', and -1. + * filesystems copy-directory function. Otherwise we simply return the + * POSIX error 'EXDEV', and -1. * * Results: * Standard Tcl error code if a function was called. @@ -4205,11 +4228,11 @@ Tcl_FSCreateDirectory(pathPtr) */ int -Tcl_FSCopyDirectory(srcPathPtr, destPathPtr, errorPtr) - Tcl_Obj* srcPathPtr; /* Pathname of directory to be copied +Tcl_FSCopyDirectory( + Tcl_Obj* srcPathPtr, /* Pathname of directory to be copied * (UTF-8). */ - Tcl_Obj *destPathPtr; /* Pathname of target directory (UTF-8). */ - Tcl_Obj **errorPtr; /* If non-NULL, then will be set to a new + Tcl_Obj *destPathPtr, /* Pathname of target directory (UTF-8). */ + Tcl_Obj **errorPtr) /* If non-NULL, then will be set to a new * object containing name of file causing * error, with refCount 1. */ { @@ -4248,13 +4271,13 @@ Tcl_FSCopyDirectory(srcPathPtr, destPathPtr, errorPtr) */ int -Tcl_FSRemoveDirectory(pathPtr, recursive, errorPtr) - Tcl_Obj *pathPtr; /* Pathname of directory to be removed +Tcl_FSRemoveDirectory( + Tcl_Obj *pathPtr, /* Pathname of directory to be removed * (UTF-8). */ - int recursive; /* If non-zero, removes directories that are - * nonempty. Otherwise, will only remove - * empty directories. */ - Tcl_Obj **errorPtr; /* If non-NULL, then will be set to a new + int recursive, /* If non-zero, removes directories that are + * nonempty. Otherwise, will only remove empty + * directories. */ + Tcl_Obj **errorPtr) /* If non-NULL, then will be set to a new * object containing name of file causing * error, with refCount 1. */ { @@ -4306,7 +4329,7 @@ Tcl_FSRemoveDirectory(pathPtr, recursive, errorPtr) * Tcl_FSGetFileSystemForPath -- * * This function determines which filesystem to use for a particular path - * object, and returns the filesystem which accepts this file. If no + * object, and returns the filesystem which accepts this file. If no * filesystem will accept this object as a valid file path, then NULL is * returned. * @@ -4319,9 +4342,9 @@ Tcl_FSRemoveDirectory(pathPtr, recursive, errorPtr) *--------------------------------------------------------------------------- */ -Tcl_Filesystem* -Tcl_FSGetFileSystemForPath(pathPtr) - Tcl_Obj* pathPtr; +Tcl_Filesystem * +Tcl_FSGetFileSystemForPath( + Tcl_Obj* pathPtr) { FilesystemRecord *fsRecPtr; Tcl_Filesystem* retVal = NULL; @@ -4332,7 +4355,7 @@ Tcl_FSGetFileSystemForPath(pathPtr) } /* - * If the object has a refCount of zero, we reject it. This is to avoid + * If the object has a refCount of zero, we reject it. This is to avoid * possible segfaults or nondeterministic memory leaks (i.e. the user * doesn't know if they should decrement the ref count on return or not). */ @@ -4344,7 +4367,7 @@ Tcl_FSGetFileSystemForPath(pathPtr) /* * Check if the filesystem has changed in some way since this object's - * internal representation was calculated. Before doing that, assure we + * internal representation was calculated. Before doing that, assure we * have the most up-to-date copy of the master filesystem. This is * accomplished by the FsGetFirstFilesystem() call. */ @@ -4356,7 +4379,7 @@ Tcl_FSGetFileSystemForPath(pathPtr) } /* - * Call each of the "pathInFilesystem" functions in succession. A + * Call each of the "pathInFilesystem" functions in succession. A * non-return value of -1 indicates the particular function has succeeded. */ @@ -4366,8 +4389,7 @@ Tcl_FSGetFileSystemForPath(pathPtr) if (proc != NULL) { ClientData clientData = NULL; - int ret = (*proc)(pathPtr, &clientData); - if (ret != -1) { + if ((*proc)(pathPtr, &clientData) != -1) { /* * We assume the type of pathPtr hasn't been changed by the * above call to the pathInFilesystemProc. @@ -4390,17 +4412,17 @@ Tcl_FSGetFileSystemForPath(pathPtr) * * This function is for use by the Win/Unix native filesystems, so that * they can easily retrieve the native (char* or TCHAR*) representation - * of a path. Other filesystems will probably want to implement similar - * functions. They basically act as a safety net around - * Tcl_FSGetInternalRep. Normally your file- system procedures will - * always be called with path objects already converted to the correct + * of a path. Other filesystems will probably want to implement similar + * functions. They basically act as a safety net around + * Tcl_FSGetInternalRep. Normally your file-system functions will always + * be called with path objects already converted to the correct * filesystem, but if for some reason they are called directly (i.e. by - * procedures not in this file), then one cannot necessarily guarantee + * functions not in this file), then one cannot necessarily guarantee * that the path object pointer is from the correct filesystem. * * Note: in the future it might be desireable to have separate versions * of this function with different signatures, for example - * Tcl_FSGetNativeWinPath, Tcl_FSGetNativeUnixPath etc. Right now, since + * Tcl_FSGetNativeWinPath, Tcl_FSGetNativeUnixPath etc. Right now, since * native paths are all string based, we use just one function. * * Results: @@ -4413,8 +4435,8 @@ Tcl_FSGetFileSystemForPath(pathPtr) */ CONST char * -Tcl_FSGetNativePath(pathPtr) - Tcl_Obj *pathPtr; +Tcl_FSGetNativePath( + Tcl_Obj *pathPtr) { return (CONST char *) Tcl_FSGetInternalRep(pathPtr, &tclNativeFilesystem); } @@ -4436,8 +4458,8 @@ Tcl_FSGetNativePath(pathPtr) */ static void -NativeFreeInternalRep(clientData) - ClientData clientData; +NativeFreeInternalRep( + ClientData clientData) { ckfree((char *) clientData); } @@ -4447,9 +4469,9 @@ NativeFreeInternalRep(clientData) * * Tcl_FSFileSystemInfo -- * - * This function returns a list of two elements. The first element is - * the name of the filesystem (e.g. "native" or "vfs"), and the second is - * the particular type of the given path within that filesystem. + * This function returns a list of two elements. The first element is the + * name of the filesystem (e.g. "native" or "vfs"), and the second is the + * particular type of the given path within that filesystem. * * Results: * A list of two elements. @@ -4460,9 +4482,9 @@ NativeFreeInternalRep(clientData) *--------------------------------------------------------------------------- */ -Tcl_Obj* -Tcl_FSFileSystemInfo(pathPtr) - Tcl_Obj* pathPtr; +Tcl_Obj * +Tcl_FSFileSystemInfo( + Tcl_Obj *pathPtr) { Tcl_Obj *resPtr; Tcl_FSFilesystemPathTypeProc *proc; @@ -4472,10 +4494,8 @@ Tcl_FSFileSystemInfo(pathPtr) return NULL; } - resPtr = Tcl_NewListObj(0,NULL); - - Tcl_ListObjAppendElement(NULL, resPtr, - Tcl_NewStringObj(fsPtr->typeName,-1)); + resPtr = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(NULL,resPtr,Tcl_NewStringObj(fsPtr->typeName,-1)); proc = fsPtr->filesystemPathTypeProc; if (proc != NULL) { @@ -4493,7 +4513,7 @@ Tcl_FSFileSystemInfo(pathPtr) * * Tcl_FSPathSeparator -- * - * This function returns the separator to be used for a given path. The + * This function returns the separator to be used for a given path. The * object returned should have a refCount of zero * * Results: @@ -4507,9 +4527,9 @@ Tcl_FSFileSystemInfo(pathPtr) *--------------------------------------------------------------------------- */ -Tcl_Obj* -Tcl_FSPathSeparator(pathPtr) - Tcl_Obj* pathPtr; +Tcl_Obj * +Tcl_FSPathSeparator( + Tcl_Obj *pathPtr) { Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); @@ -4545,9 +4565,9 @@ Tcl_FSPathSeparator(pathPtr) *--------------------------------------------------------------------------- */ -static Tcl_Obj* -NativeFilesystemSeparator(pathPtr) - Tcl_Obj* pathPtr; +static Tcl_Obj * +NativeFilesystemSeparator( + Tcl_Obj *pathPtr) { char *separator = NULL; /* lint */ switch (tclPlatform) { @@ -4569,10 +4589,10 @@ NativeFilesystemSeparator(pathPtr) * * TclStatInsertProc -- * - * Insert the passed procedure pointer at the head of the list of + * Insert the passed function pointer at the head of the list of * functions which are used during a call to 'TclStat(...)'. The passed * function should behave exactly like 'TclStat' when called during that - * time (see 'TclStat(...)' for more information). The function will be + * time (see 'TclStat(...)' for more information). The function will be * added even if it already in the list. * * Results: @@ -4586,8 +4606,8 @@ NativeFilesystemSeparator(pathPtr) */ int -TclStatInsertProc (proc) - TclStatProc_ *proc; +TclStatInsertProc( + TclStatProc_ *proc) { int retVal = TCL_ERROR; @@ -4616,10 +4636,10 @@ TclStatInsertProc (proc) * TclStatDeleteProc -- * * Removed the passed function pointer from the list of 'TclStat' - * functions. Ensures that the built-in stat function is not removvable. + * functions. Ensures that the built-in stat function is not removable. * * Results: - * TCL_OK if the procedure pointer was successfully removed, TCL_ERROR + * TCL_OK if the function pointer was successfully removed, TCL_ERROR * otherwise. * * Side effects: @@ -4629,8 +4649,8 @@ TclStatInsertProc (proc) */ int -TclStatDeleteProc (proc) - TclStatProc_ *proc; +TclStatDeleteProc( + TclStatProc_ *proc) { int retVal = TCL_ERROR; StatProc *tmpStatProcPtr; @@ -4641,7 +4661,7 @@ TclStatDeleteProc (proc) /* * Traverse the 'statProcList' looking for the particular node whose - * 'proc' member matches 'proc' and remove that one from the list. Ensure + * 'proc' member matches 'proc' and remove that one from the list. Ensure * that the "default" node cannot be removed. */ @@ -4672,11 +4692,11 @@ TclStatDeleteProc (proc) * * TclAccessInsertProc -- * - * Insert the passed procedure pointer at the head of the list of - * functions which are used during a call to 'TclAccess(...)'. The - * passed function should behave exactly like 'TclAccess' when called - * during that time (see 'TclAccess(...)' for more information). The - * function will be added even if it already in the list. + * Insert the passed function pointer at the head of the list of + * functions which are used during a call to 'TclAccess(...)'. The passed + * function should behave exactly like 'TclAccess' when called during + * that time (see 'TclAccess(...)' for more information). The function + * will be added even if it already in the list. * * Results: * Normally TCL_OK; TCL_ERROR if memory for a new node in the list could @@ -4689,8 +4709,8 @@ TclStatDeleteProc (proc) */ int -TclAccessInsertProc(proc) - TclAccessProc_ *proc; +TclAccessInsertProc( + TclAccessProc_ *proc) { int retVal = TCL_ERROR; @@ -4719,11 +4739,10 @@ TclAccessInsertProc(proc) * TclAccessDeleteProc -- * * Removed the passed function pointer from the list of 'TclAccess' - * functions. Ensures that the built-in access function is not - * removvable. + * functions. Ensures that the built-in access function is not removable. * * Results: - * TCL_OK if the procedure pointer was successfully removed, TCL_ERROR + * TCL_OK if the function pointer was successfully removed, TCL_ERROR * otherwise. * * Side effects: @@ -4733,8 +4752,8 @@ TclAccessInsertProc(proc) */ int -TclAccessDeleteProc(proc) - TclAccessProc_ *proc; +TclAccessDeleteProc( + TclAccessProc_ *proc) { int retVal = TCL_ERROR; AccessProc *tmpAccessProcPtr; @@ -4742,7 +4761,7 @@ TclAccessDeleteProc(proc) /* * Traverse the 'accessProcList' looking for the particular node whose - * 'proc' member matches 'proc' and remove that one from the list. Ensure + * 'proc' member matches 'proc' and remove that one from the list. Ensure * that the "default" node cannot be removed. */ @@ -4774,12 +4793,12 @@ TclAccessDeleteProc(proc) * * TclOpenFileChannelInsertProc -- * - * Insert the passed procedure pointer at the head of the list of - * functions which are used during a call to - * 'Tcl_OpenFileChannel(...)'. The passed function should behave exactly - * like 'Tcl_OpenFileChannel' when called during that time (see - * 'Tcl_OpenFileChannel(...)' for more information). The function will be - * added even if it already in the list. + * Insert the passed function pointer at the head of the list of + * functions which are used during a call to 'Tcl_OpenFileChannel(...)'. + * The passed function should behave exactly like 'Tcl_OpenFileChannel' + * when called during that time (see 'Tcl_OpenFileChannel(...)' for more + * information). The function will be added even if it already in the + * list. * * Results: * Normally TCL_OK; TCL_ERROR if memory for a new node in the list could @@ -4793,8 +4812,8 @@ TclAccessDeleteProc(proc) */ int -TclOpenFileChannelInsertProc(proc) - TclOpenFileChannelProc_ *proc; +TclOpenFileChannelInsertProc( + TclOpenFileChannelProc_ *proc) { int retVal = TCL_ERROR; @@ -4822,11 +4841,11 @@ TclOpenFileChannelInsertProc(proc) * TclOpenFileChannelDeleteProc -- * * Removed the passed function pointer from the list of - * 'Tcl_OpenFileChannel' functions. Ensures that the built-in open file + * 'Tcl_OpenFileChannel' functions. Ensures that the built-in open file * channel function is not removable. * * Results: - * TCL_OK if the procedure pointer was successfully removed, TCL_ERROR + * TCL_OK if the function pointer was successfully removed, TCL_ERROR * otherwise. * * Side effects: @@ -4836,8 +4855,8 @@ TclOpenFileChannelInsertProc(proc) */ int -TclOpenFileChannelDeleteProc(proc) - TclOpenFileChannelProc_ *proc; +TclOpenFileChannelDeleteProc( + TclOpenFileChannelProc_ *proc) { int retVal = TCL_ERROR; OpenFileChannelProc *tmpOpenFileChannelProcPtr = openFileChannelProcList; diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 794f1c9..0b5401d 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIndexObj.c,v 1.26 2005/07/21 16:58:09 dgp Exp $ + * RCS: @(#) $Id: tclIndexObj.c,v 1.27 2005/11/01 15:30:52 dkf Exp $ */ #include "tclInt.h" @@ -19,12 +19,10 @@ * Prototypes for functions defined later in this file: */ -static int SetIndexFromAny _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr)); -static void UpdateStringOfIndex _ANSI_ARGS_((Tcl_Obj *objPtr)); -static void DupIndex _ANSI_ARGS_((Tcl_Obj *srcPtr, - Tcl_Obj *dupPtr)); -static void FreeIndex _ANSI_ARGS_((Tcl_Obj *objPtr)); +static int SetIndexFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); +static void UpdateStringOfIndex(Tcl_Obj *objPtr); +static void DupIndex(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr); +static void FreeIndex(Tcl_Obj *objPtr); /* * The structure below defines the index Tcl object type by means of functions @@ -48,7 +46,7 @@ static Tcl_ObjType indexType = { */ typedef struct { - VOID *tablePtr; /* Pointer to the table of strings */ + void *tablePtr; /* Pointer to the table of strings */ int offset; /* Offset between table entries */ int index; /* Selected index into table. */ } IndexRep; @@ -56,6 +54,7 @@ typedef struct { /* * The following macros greatly simplify moving through a table... */ + #define STRING_AT(table, offset, index) \ (*((CONST char * CONST *)(((char *)(table)) + ((offset) * (index))))) #define NEXT_ENTRY(table, offset) \ @@ -89,16 +88,16 @@ typedef struct { */ int -Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr; /* Object containing the string to lookup. */ - CONST char **tablePtr; /* Array of strings to compare against the +Tcl_GetIndexFromObj( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr, /* Object containing the string to lookup. */ + CONST char **tablePtr, /* Array of strings to compare against the * value of objPtr; last entry must be NULL * and there must not be duplicate entries. */ - CONST char *msg; /* Identifying word to use in error + CONST char *msg, /* Identifying word to use in error * messages. */ - int flags; /* 0 or TCL_EXACT */ - int *indexPtr; /* Place to store resulting integer index. */ + int flags, /* 0 or TCL_EXACT */ + int *indexPtr) /* Place to store resulting integer index. */ { /* @@ -115,8 +114,8 @@ Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) * on odd platforms like a Cray PVP... */ - if (indexRep->tablePtr == (VOID *)tablePtr && - indexRep->offset == sizeof(char *)) { + if (indexRep->tablePtr == (void *) tablePtr + && indexRep->offset == sizeof(char *)) { *indexPtr = indexRep->index; return TCL_OK; } @@ -152,20 +151,19 @@ Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) */ int -Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, - indexPtr) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr; /* Object containing the string to lookup. */ - CONST VOID *tablePtr; /* The first string in the table. The second +Tcl_GetIndexFromObjStruct( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr, /* Object containing the string to lookup. */ + CONST VOID *tablePtr, /* The first string in the table. The second * string will be at this address plus the * offset, the third plus the offset again, * etc. The last entry must be NULL and there * must not be duplicate entries. */ - int offset; /* The number of bytes between entries */ - CONST char *msg; /* Identifying word to use in error + int offset, /* The number of bytes between entries */ + CONST char *msg, /* Identifying word to use in error * messages. */ - int flags; /* 0 or TCL_EXACT */ - int *indexPtr; /* Place to store resulting integer index. */ + int flags, /* 0 or TCL_EXACT */ + int *indexPtr) /* Place to store resulting integer index. */ { int index, length, i, numAbbrev; char *key, *p1; @@ -252,10 +250,10 @@ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, } else { TclFreeIntRep(objPtr); indexRep = (IndexRep *) ckalloc(sizeof(IndexRep)); - objPtr->internalRep.otherValuePtr = (VOID *) indexRep; + objPtr->internalRep.otherValuePtr = (void *) indexRep; objPtr->typePtr = &indexType; } - indexRep->tablePtr = (VOID*) tablePtr; + indexRep->tablePtr = (void *) tablePtr; indexRep->offset = offset; indexRep->index = index; @@ -274,17 +272,15 @@ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, Tcl_SetObjResult(interp, resultPtr); Tcl_AppendStringsToObj(resultPtr, (numAbbrev > 1) ? "ambiguous " : "bad ", msg, " \"", key, - "\": must be ", STRING_AT(tablePtr,offset,0), (char*) NULL); + "\": must be ", STRING_AT(tablePtr, offset, 0), NULL); for (entryPtr = NEXT_ENTRY(tablePtr, offset), count = 0; *entryPtr != NULL; entryPtr = NEXT_ENTRY(entryPtr, offset), count++) { if (*NEXT_ENTRY(entryPtr, offset) == NULL) { - Tcl_AppendStringsToObj(resultPtr, - (count > 0) ? ", or " : " or ", *entryPtr, - (char *) NULL); + Tcl_AppendStringsToObj(resultPtr, ((count > 0) ? "," : ""), + " or ", *entryPtr, NULL); } else { - Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr, - (char *) NULL); + Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr, NULL); } } } @@ -312,9 +308,9 @@ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, */ static int -SetIndexFromAny(interp, objPtr) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr; /* The object to convert. */ +SetIndexFromAny( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr) /* The object to convert. */ { Tcl_SetObjResult(interp, Tcl_NewStringObj( "can't convert value to index except via Tcl_GetIndexFromObj API", @@ -340,8 +336,8 @@ SetIndexFromAny(interp, objPtr) */ static void -UpdateStringOfIndex(objPtr) - Tcl_Obj *objPtr; +UpdateStringOfIndex( + Tcl_Obj *objPtr) { IndexRep *indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr; register char *buf; @@ -374,14 +370,15 @@ UpdateStringOfIndex(objPtr) */ static void -DupIndex(srcPtr, dupPtr) - Tcl_Obj *srcPtr, *dupPtr; +DupIndex( + Tcl_Obj *srcPtr, + Tcl_Obj *dupPtr) { IndexRep *srcIndexRep = (IndexRep *) srcPtr->internalRep.otherValuePtr; IndexRep *dupIndexRep = (IndexRep *) ckalloc(sizeof(IndexRep)); memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep)); - dupPtr->internalRep.otherValuePtr = (VOID *) dupIndexRep; + dupPtr->internalRep.otherValuePtr = (void *) dupIndexRep; dupPtr->typePtr = &indexType; } @@ -403,8 +400,8 @@ DupIndex(srcPtr, dupPtr) */ static void -FreeIndex(objPtr) - Tcl_Obj *objPtr; +FreeIndex( + Tcl_Obj *objPtr) { ckfree((char *) objPtr->internalRep.otherValuePtr); } @@ -449,12 +446,12 @@ FreeIndex(objPtr) */ void -Tcl_WrongNumArgs(interp, objc, objv, message) - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments to print from objv. */ - Tcl_Obj *CONST objv[]; /* Initial argument objects, which should be +Tcl_WrongNumArgs( + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments to print from objv. */ + Tcl_Obj *CONST objv[], /* Initial argument objects, which should be * included in the error message. */ - CONST char *message; /* Error message to print after the leading + CONST char *message) /* Error message to print after the leading * objects in objv. The message may be * NULL. */ { @@ -554,7 +551,7 @@ Tcl_WrongNumArgs(interp, objc, objv, message) */ if (i<toPrint-1 || objc!=0 || message!=NULL) { - Tcl_AppendStringsToObj(objPtr, " ", (char *) NULL); + Tcl_AppendStringsToObj(objPtr, " ", NULL); } } } @@ -574,7 +571,7 @@ Tcl_WrongNumArgs(interp, objc, objv, message) if (objv[i]->typePtr == &indexType) { indexRep = (IndexRep *) objv[i]->internalRep.otherValuePtr; - Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), (char *) NULL); + Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), NULL); } else { /* * Quote the argument if it contains spaces (Bug 942757). @@ -603,7 +600,7 @@ Tcl_WrongNumArgs(interp, objc, objv, message) */ if (i<objc-1 || message!=NULL) { - Tcl_AppendStringsToObj(objPtr, " ", (char *) NULL); + Tcl_AppendStringsToObj(objPtr, " ", NULL); } } @@ -614,9 +611,9 @@ Tcl_WrongNumArgs(interp, objc, objv, message) */ if (message != NULL) { - Tcl_AppendStringsToObj(objPtr, message, (char *) NULL); + Tcl_AppendStringsToObj(objPtr, message, NULL); } - Tcl_AppendStringsToObj(objPtr, "\"", (char *) NULL); + Tcl_AppendStringsToObj(objPtr, "\"", NULL); Tcl_SetObjResult(interp, objPtr); #undef MAY_QUOTE_WORD #undef AFTER_FIRST_WORD diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index e1d108d..a9ee861 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -13,11 +13,12 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclLiteral.c,v 1.26 2005/10/19 18:39:58 dgp Exp $ + * RCS: @(#) $Id: tclLiteral.c,v 1.27 2005/11/01 15:30:52 dkf Exp $ */ #include "tclInt.h" #include "tclCompile.h" + /* * When there are this many entries per bucket, on average, rebuild a * literal's hash table to make it larger. @@ -26,25 +27,21 @@ #define REBUILD_MULTIPLIER 3 /* - * Procedure prototypes for static procedures in this file: + * Function prototypes for static functions in this file: */ -static int AddLocalLiteralEntry _ANSI_ARGS_(( - CompileEnv *envPtr, LiteralEntry *globalPtr, - int localHash)); -static void ExpandLocalLiteralArray _ANSI_ARGS_(( - CompileEnv *envPtr)); -static unsigned int HashString _ANSI_ARGS_((CONST char *bytes, - int length)); -static void RebuildLiteralTable _ANSI_ARGS_(( - LiteralTable *tablePtr)); +static int AddLocalLiteralEntry(CompileEnv *envPtr, + LiteralEntry *globalPtr, int localHash); +static void ExpandLocalLiteralArray(CompileEnv *envPtr); +static unsigned int HashString(CONST char *bytes, int length); +static void RebuildLiteralTable(LiteralTable *tablePtr); /* *---------------------------------------------------------------------- * * TclInitLiteralTable -- * - * This procedure is called to initialize the fields of a literal table + * This function is called to initialize the fields of a literal table * structure for either an interpreter or a compilation's CompileEnv * structure. * @@ -58,8 +55,8 @@ static void RebuildLiteralTable _ANSI_ARGS_(( */ void -TclInitLiteralTable(tablePtr) - register LiteralTable *tablePtr; +TclInitLiteralTable( + register LiteralTable *tablePtr) /* Pointer to table structure, which is * supplied by the caller. */ { @@ -73,7 +70,7 @@ TclInitLiteralTable(tablePtr) tablePtr->staticBuckets[2] = tablePtr->staticBuckets[3] = 0; tablePtr->numBuckets = TCL_SMALL_HASH_TABLE; tablePtr->numEntries = 0; - tablePtr->rebuildSize = TCL_SMALL_HASH_TABLE*REBUILD_MULTIPLIER; + tablePtr->rebuildSize = TCL_SMALL_HASH_TABLE * REBUILD_MULTIPLIER; tablePtr->mask = 3; } @@ -82,8 +79,8 @@ TclInitLiteralTable(tablePtr) * * TclCleanupLiteralTable -- * - * This procedure frees the internal representation of every literal in a - * literal table. It is called prior to deleting an interp, so that + * This function frees the internal representation of every literal in a + * literal table. It is called prior to deleting an interp, so that * variable refs will be cleaned up properly. * * Results: @@ -96,10 +93,9 @@ TclInitLiteralTable(tablePtr) */ void -TclCleanupLiteralTable( interp, tablePtr ) - Tcl_Interp* interp; /* Interpreter containing literals to - * purge. */ - LiteralTable* tablePtr; /* Points to the literal table being +TclCleanupLiteralTable( + Tcl_Interp *interp, /* Interpreter containing literals to purge */ + LiteralTable *tablePtr) /* Points to the literal table being * cleaned. */ { int i; @@ -113,7 +109,7 @@ TclCleanupLiteralTable( interp, tablePtr ) * the current bucket. */ #ifdef TCL_COMPILE_DEBUG - TclVerifyGlobalLiteralTable( (Interp*) interp ); + TclVerifyGlobalLiteralTable((Interp *) interp); #endif /* TCL_COMPILE_DEBUG */ for (i=0 ; i<tablePtr->numBuckets ; i++) { @@ -153,7 +149,7 @@ TclCleanupLiteralTable( interp, tablePtr ) * * TclDeleteLiteralTable -- * - * This procedure frees up everything associated with a literal table + * This function frees up everything associated with a literal table * except for the table's structure itself. It is called when the * interpreter is deleted. * @@ -169,10 +165,10 @@ TclCleanupLiteralTable( interp, tablePtr ) */ void -TclDeleteLiteralTable(interp, tablePtr) - Tcl_Interp *interp; /* Interpreter containing shared literals +TclDeleteLiteralTable( + Tcl_Interp *interp, /* Interpreter containing shared literals * referenced by the table to delete. */ - LiteralTable *tablePtr; /* Points to the literal table to delete. */ + LiteralTable *tablePtr) /* Points to the literal table to delete. */ { LiteralEntry *entryPtr, *nextPtr; Tcl_Obj *objPtr; @@ -191,13 +187,13 @@ TclDeleteLiteralTable(interp, tablePtr) /* * We used to call TclReleaseLiteral for each literal in the table, which * is rather inefficient as it causes one lookup-by-hash for each - * reference to the literal. We now rely at interp-deletion on each + * reference to the literal. We now rely at interp-deletion on each * bytecode object to release its references to the literal Tcl_Obj * without requiring that it updates the global table itself, and deal * here only with the table. */ - for (i = 0; i < tablePtr->numBuckets; i++) { + for (i=0 ; i<tablePtr->numBuckets ; i++) { entryPtr = tablePtr->buckets[i]; while (entryPtr != NULL) { objPtr = entryPtr->objPtr; @@ -235,7 +231,7 @@ TclDeleteLiteralTable(interp, tablePtr) * global table. We then add a reference to the shared literal in the * CompileEnv's literal array. * - * If LITERAL_ON_HEAP is set in flags, this procedure is given ownership + * If LITERAL_ON_HEAP is set in flags, this function is given ownership * of the string: if an object is created then its string representation * is set directly from string, otherwise the string is freed. Typically, * a caller sets LITERAL_ON_HEAP if "string" is an already heap-allocated @@ -245,18 +241,18 @@ TclDeleteLiteralTable(interp, tablePtr) */ int -TclRegisterLiteral(envPtr, bytes, length, flags) - CompileEnv *envPtr; /* Points to the CompileEnv in whose object +TclRegisterLiteral( + CompileEnv *envPtr, /* Points to the CompileEnv in whose object * array an object is found or created. */ - register char *bytes; /* Points to string for which to find or + register char *bytes, /* Points to string for which to find or * create an object in CompileEnv's object * array. */ - int length; /* Number of bytes in the string. If < 0, the + int length, /* Number of bytes in the string. If < 0, the * string consists of all bytes up to the * first null character. */ - int flags; /* If LITERAL_ON_HEAP then the caller already + int flags) /* If LITERAL_ON_HEAP then the caller already * malloc'd bytes and ownership is passed to - * this procedure. If LITERAL_NS_SCOPE then + * this function. If LITERAL_NS_SCOPE then * the literal shouldnot be shared accross * namespaces. */ { @@ -275,13 +271,13 @@ TclRegisterLiteral(envPtr, bytes, length, flags) hash = HashString(bytes, length); /* - * Is the literal already in the CompileEnv's local literal array? If so, + * Is the literal already in the CompileEnv's local literal array? If so, * just return its index. */ localHash = (hash & localTablePtr->mask); - for (localPtr = localTablePtr->buckets[localHash]; - localPtr != NULL; localPtr = localPtr->nextPtr) { + for (localPtr=localTablePtr->buckets[localHash] ; localPtr!=NULL; + localPtr = localPtr->nextPtr) { objPtr = localPtr->objPtr; if ((objPtr->length == length) && ((length == 0) || ((objPtr->bytes[0] == bytes[0]) @@ -316,8 +312,8 @@ TclRegisterLiteral(envPtr, bytes, length, flags) */ globalHash = (hash & globalTablePtr->mask); - for (globalPtr = globalTablePtr->buckets[globalHash]; - globalPtr != NULL; globalPtr = globalPtr->nextPtr) { + for (globalPtr=globalTablePtr->buckets[globalHash] ; globalPtr!=NULL; + globalPtr = globalPtr->nextPtr) { objPtr = globalPtr->objPtr; if ((globalPtr->nsPtr == nsPtr) && (objPtr->length == length) && ((length == 0) @@ -434,10 +430,10 @@ TclRegisterLiteral(envPtr, bytes, length, flags) */ LiteralEntry * -TclLookupLiteralEntry(interp, objPtr) - Tcl_Interp *interp; /* Interpreter for which objPtr was created to +TclLookupLiteralEntry( + Tcl_Interp *interp, /* Interpreter for which objPtr was created to * hold a literal. */ - register Tcl_Obj *objPtr; /* Points to a Tcl object holding a literal + register Tcl_Obj *objPtr) /* Points to a Tcl object holding a literal * that was previously created by a call to * TclRegisterLiteral. */ { @@ -449,8 +445,8 @@ TclLookupLiteralEntry(interp, objPtr) bytes = Tcl_GetStringFromObj(objPtr, &length); globalHash = (HashString(bytes, length) & globalTablePtr->mask); - for (entryPtr = globalTablePtr->buckets[globalHash]; - entryPtr != NULL; entryPtr = entryPtr->nextPtr) { + for (entryPtr=globalTablePtr->buckets[globalHash] ; entryPtr!=NULL; + entryPtr=entryPtr->nextPtr) { if (entryPtr->objPtr == objPtr) { return entryPtr; } @@ -479,12 +475,12 @@ TclLookupLiteralEntry(interp, objPtr) */ void -TclHideLiteral(interp, envPtr, index) - Tcl_Interp *interp; /* Interpreter for which objPtr was created to +TclHideLiteral( + Tcl_Interp *interp, /* Interpreter for which objPtr was created to * hold a literal. */ - register CompileEnv *envPtr;/* Points to CompileEnv whose literal array + register CompileEnv *envPtr,/* Points to CompileEnv whose literal array * contains the entry being hidden. */ - int index; /* The index of the entry in the literal + int index) /* The index of the entry in the literal * array. */ { LiteralEntry **nextPtrPtr, *entryPtr, *lPtr; @@ -497,9 +493,9 @@ TclHideLiteral(interp, envPtr, index) /* * To avoid unwanted sharing we need to copy the object and remove it from - * the local and global literal tables. It still has a slot in the - * literal array so it can be referred to by byte codes, but it will not - * be matched by literal searches. + * the local and global literal tables. It still has a slot in the literal + * array so it can be referred to by byte codes, but it will not be + * matched by literal searches. */ newObjPtr = Tcl_DuplicateObj(lPtr->objPtr); @@ -544,11 +540,11 @@ TclHideLiteral(interp, envPtr, index) */ int -TclAddLiteralObj(envPtr, objPtr, litPtrPtr) - register CompileEnv *envPtr;/* Points to CompileEnv in whose literal array +TclAddLiteralObj( + register CompileEnv *envPtr,/* Points to CompileEnv in whose literal array * the object is to be inserted. */ - Tcl_Obj *objPtr; /* The object to insert into the array. */ - LiteralEntry **litPtrPtr; /* The location where the pointer to the new + Tcl_Obj *objPtr, /* The object to insert into the array. */ + LiteralEntry **litPtrPtr) /* The location where the pointer to the new * literal entry should be stored. May be * NULL. */ { @@ -595,12 +591,12 @@ TclAddLiteralObj(envPtr, objPtr, litPtrPtr) */ static int -AddLocalLiteralEntry(envPtr, globalPtr, localHash) - register CompileEnv *envPtr;/* Points to CompileEnv in whose literal array +AddLocalLiteralEntry( + register CompileEnv *envPtr,/* Points to CompileEnv in whose literal array * the object is to be inserted. */ - LiteralEntry *globalPtr; /* Points to the global LiteralEntry for the + LiteralEntry *globalPtr, /* Points to the global LiteralEntry for the * literal to add to the CompileEnv. */ - int localHash; /* Hash value for the literal's string. */ + int localHash) /* Hash value for the literal's string. */ { register LiteralTable *localTablePtr = &(envPtr->localLitTable); LiteralEntry *localPtr; @@ -659,7 +655,7 @@ AddLocalLiteralEntry(envPtr, globalPtr, localHash) * * ExpandLocalLiteralArray -- * - * Procedure that uses malloc to allocate more storage for a CompileEnv's + * Function that uses malloc to allocate more storage for a CompileEnv's * local literal array. * * Results: @@ -675,8 +671,8 @@ AddLocalLiteralEntry(envPtr, globalPtr, localHash) */ static void -ExpandLocalLiteralArray(envPtr) - register CompileEnv *envPtr;/* Points to the CompileEnv whose object array +ExpandLocalLiteralArray( + register CompileEnv *envPtr)/* Points to the CompileEnv whose object array * must be enlarged. */ { /* @@ -697,7 +693,7 @@ ExpandLocalLiteralArray(envPtr) * literal table's bucket array. */ - memcpy((VOID *) newArrayPtr, (VOID *) currArrayPtr, currBytes); + memcpy((void *) newArrayPtr, (void *) currArrayPtr, currBytes); for (i=0 ; i<currElems ; i++) { if (currArrayPtr[i].nextPtr == NULL) { newArrayPtr[i].nextPtr = NULL; @@ -731,7 +727,7 @@ ExpandLocalLiteralArray(envPtr) * * TclReleaseLiteral -- * - * This procedure releases a reference to one of the shared Tcl objects + * This function releases a reference to one of the shared Tcl objects * that hold literals. It is called to release the literals referenced by * a ByteCode that is being destroyed, and it is also called by * TclDeleteLiteralTable. @@ -748,10 +744,10 @@ ExpandLocalLiteralArray(envPtr) */ void -TclReleaseLiteral(interp, objPtr) - Tcl_Interp *interp; /* Interpreter for which objPtr was created to +TclReleaseLiteral( + Tcl_Interp *interp, /* Interpreter for which objPtr was created to * hold a literal. */ - register Tcl_Obj *objPtr; /* Points to a literal object that was + register Tcl_Obj *objPtr) /* Points to a literal object that was * previously created by a call to * TclRegisterLiteral. */ { @@ -770,9 +766,8 @@ TclReleaseLiteral(interp, objPtr) * local literal. */ - for (prevPtr = NULL, entryPtr = globalTablePtr->buckets[index]; - entryPtr != NULL; - prevPtr = entryPtr, entryPtr = entryPtr->nextPtr) { + for (prevPtr=NULL, entryPtr=globalTablePtr->buckets[index]; + entryPtr!=NULL ; prevPtr=entryPtr, entryPtr=entryPtr->nextPtr) { if (entryPtr->objPtr == objPtr) { entryPtr->refCount--; @@ -826,9 +821,9 @@ TclReleaseLiteral(interp, objPtr) */ static unsigned int -HashString(bytes, length) - register CONST char *bytes; /* String for which to compute hash value. */ - int length; /* Number of bytes in the string. */ +HashString( + register CONST char *bytes, /* String for which to compute hash value. */ + int length) /* Number of bytes in the string. */ { register unsigned int result; register int i; @@ -842,7 +837,7 @@ HashString(bytes, length) * * 1. Multiplying by 10 is perfect for keys that are decimal strings, and * multiplying by 9 is just about as good. - * 2. Times-9 is (shift-left-3) plus (old). This means that each + * 2. Times-9 is (shift-left-3) plus (old). This means that each * character's bits hang around in the low-order bits of the hash value * for ever, plus they spread fairly rapidly up to the high-order bits * to fill out the hash value. This seems works well both for decimal @@ -861,7 +856,7 @@ HashString(bytes, length) * * RebuildLiteralTable -- * - * This procedure is invoked when the ratio of entries to hash buckets + * This function is invoked when the ratio of entries to hash buckets * becomes too large in a local or global literal table. It allocates a * larger bucket array and moves the entries into the new buckets. * @@ -875,8 +870,8 @@ HashString(bytes, length) */ static void -RebuildLiteralTable(tablePtr) - register LiteralTable *tablePtr; +RebuildLiteralTable( + register LiteralTable *tablePtr) /* Local or global table to enlarge. */ { LiteralEntry **oldBuckets; @@ -897,9 +892,8 @@ RebuildLiteralTable(tablePtr) tablePtr->numBuckets *= 4; tablePtr->buckets = (LiteralEntry **) ckalloc((unsigned) (tablePtr->numBuckets * sizeof(LiteralEntry *))); - for (count = tablePtr->numBuckets, newChainPtr = tablePtr->buckets; - count > 0; - count--, newChainPtr++) { + for (count=tablePtr->numBuckets, newChainPtr=tablePtr->buckets; + count>0 ; count--, newChainPtr++) { *newChainPtr = NULL; } tablePtr->rebuildSize *= 4; @@ -950,8 +944,8 @@ RebuildLiteralTable(tablePtr) */ char * -TclLiteralStats(tablePtr) - LiteralTable *tablePtr; /* Table for which to produce stats. */ +TclLiteralStats( + LiteralTable *tablePtr) /* Table for which to produce stats. */ { #define NUM_COUNTERS 10 int count[NUM_COUNTERS], overflow, i, j; @@ -964,15 +958,15 @@ TclLiteralStats(tablePtr) * number of entries in the chain. */ - for (i = 0; i < NUM_COUNTERS; i++) { + for (i=0 ; i<NUM_COUNTERS ; i++) { count[i] = 0; } overflow = 0; average = 0.0; - for (i = 0; i < tablePtr->numBuckets; i++) { + for (i=0 ; i<tablePtr->numBuckets ; i++) { j = 0; - for (entryPtr = tablePtr->buckets[i]; entryPtr != NULL; - entryPtr = entryPtr->nextPtr) { + for (entryPtr=tablePtr->buckets[i] ; entryPtr!=NULL; + entryPtr=entryPtr->nextPtr) { j++; } if (j < NUM_COUNTERS) { @@ -992,7 +986,7 @@ TclLiteralStats(tablePtr) sprintf(result, "%d entries in table, %d buckets\n", tablePtr->numEntries, tablePtr->numBuckets); p = result + strlen(result); - for (i = 0; i < NUM_COUNTERS; i++) { + for (i=0 ; i<NUM_COUNTERS ; i++) { sprintf(p, "number of buckets with %d entries: %d\n", i, count[i]); p += strlen(p); @@ -1023,8 +1017,8 @@ TclLiteralStats(tablePtr) */ void -TclVerifyLocalLiteralTable(envPtr) - CompileEnv *envPtr; /* Points to CompileEnv whose literal table is +TclVerifyLocalLiteralTable( + CompileEnv *envPtr) /* Points to CompileEnv whose literal table is * to be validated. */ { register LiteralTable *localTablePtr = &(envPtr->localLitTable); @@ -1034,9 +1028,9 @@ TclVerifyLocalLiteralTable(envPtr) int length, count; count = 0; - for (i = 0; i < localTablePtr->numBuckets; i++) { - for (localPtr = localTablePtr->buckets[i]; - localPtr != NULL; localPtr = localPtr->nextPtr) { + for (i=0 ; i<localTablePtr->numBuckets ; i++) { + for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL; + localPtr=localPtr->nextPtr) { count++; if (localPtr->refCount != -1) { bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length); @@ -1077,8 +1071,8 @@ TclVerifyLocalLiteralTable(envPtr) */ void -TclVerifyGlobalLiteralTable(iPtr) - Interp *iPtr; /* Points to interpreter whose global literal +TclVerifyGlobalLiteralTable( + Interp *iPtr) /* Points to interpreter whose global literal * table is to be validated. */ { register LiteralTable *globalTablePtr = &(iPtr->literalTable); @@ -1088,9 +1082,9 @@ TclVerifyGlobalLiteralTable(iPtr) int length, count; count = 0; - for (i = 0; i < globalTablePtr->numBuckets; i++) { - for (globalPtr = globalTablePtr->buckets[i]; - globalPtr != NULL; globalPtr = globalPtr->nextPtr) { + for (i=0 ; i<globalTablePtr->numBuckets ; i++) { + for (globalPtr=globalTablePtr->buckets[i] ; globalPtr!=NULL; + globalPtr=globalPtr->nextPtr) { count++; if (globalPtr->refCount < 1) { bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length); diff --git a/generic/tclMain.c b/generic/tclMain.c index ae7f3b9..7961d0f 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclMain.c,v 1.34 2005/10/14 11:14:31 patthoyts Exp $ + * RCS: @(#) $Id: tclMain.c,v 1.35 2005/11/01 15:30:52 dkf Exp $ */ #include "tclInt.h" @@ -25,16 +25,15 @@ #define DEFAULT_PRIMARY_PROMPT "% " /* - * Declarations for various library procedures and variables (don't want to + * Declarations for various library functions and variables (don't want to * include tclPort.h here, because people might copy this file out of the Tcl * source directory to make their own modified versions). */ -extern CRTIMPORT int isatty _ANSI_ARGS_((int fd)); +extern CRTIMPORT int isatty(int fd); static Tcl_Obj *tclStartupScriptPath = NULL; static Tcl_Obj *tclStartupScriptEncoding = NULL; - static Tcl_MainLoopProc *mainLoopProc = NULL; /* @@ -63,13 +62,11 @@ typedef struct InteractiveState { } InteractiveState; /* - * Forward declarations for procedures defined later in this file. + * Forward declarations for functions defined later in this file. */ -static void Prompt _ANSI_ARGS_((Tcl_Interp *interp, - PromptType *promptPtr)); -static void StdinProc _ANSI_ARGS_((ClientData clientData, - int mask)); +static void Prompt(Tcl_Interp *interp, PromptType *promptPtr); +static void StdinProc(ClientData clientData, int mask); /* *---------------------------------------------------------------------- @@ -88,9 +85,9 @@ static void StdinProc _ANSI_ARGS_((ClientData clientData, */ void -Tcl_SetStartupScript(path, encoding) - Tcl_Obj *path; /* Filesystem path of startup script file */ - CONST char *encoding; /* Encoding of the data in that file */ +Tcl_SetStartupScript( + Tcl_Obj *path, /* Filesystem path of startup script file */ + CONST char *encoding) /* Encoding of the data in that file */ { Tcl_Obj *newEncoding = NULL; if (encoding != NULL) { @@ -135,8 +132,8 @@ Tcl_SetStartupScript(path, encoding) */ Tcl_Obj * -Tcl_GetStartupScript(encodingPtr) - CONST char **encodingPtr; /* When not NULL, points to storage for the +Tcl_GetStartupScript( + CONST char **encodingPtr) /* When not NULL, points to storage for the * (CONST char *) that points to the * registered encoding name for the startup * script */ @@ -163,15 +160,15 @@ Tcl_GetStartupScript(encodingPtr) * None. * * Side effects: - * This procedure initializes the VFS path of the Tcl script to run at + * This function initializes the VFS path of the Tcl script to run at * startup. * *---------------------------------------------------------------------- */ void -TclSetStartupScriptPath(path) - Tcl_Obj *path; +TclSetStartupScriptPath( + Tcl_Obj *path) { Tcl_SetStartupScript(path, NULL); } @@ -194,7 +191,7 @@ TclSetStartupScriptPath(path) */ Tcl_Obj * -TclGetStartupScriptPath() +TclGetStartupScriptPath(void) { return Tcl_GetStartupScript(NULL); } @@ -211,15 +208,15 @@ TclGetStartupScriptPath() * None. * * Side effects: - * This procedure initializes the file name of the Tcl script to run at + * This function initializes the file name of the Tcl script to run at * startup. * *---------------------------------------------------------------------- */ void -TclSetStartupScriptFileName(fileName) - CONST char *fileName; +TclSetStartupScriptFileName( + CONST char *fileName) { Tcl_Obj *path = Tcl_NewStringObj(fileName,-1); Tcl_SetStartupScript(path, NULL); @@ -243,7 +240,7 @@ TclSetStartupScriptFileName(fileName) */ CONST char * -TclGetStartupScriptFileName() +TclGetStartupScriptFileName(void) { Tcl_Obj *path = Tcl_GetStartupScript(NULL); @@ -257,9 +254,9 @@ TclGetStartupScriptFileName() * * Tcl_SourceRCFile -- * - * This procedure is typically invoked by Tcl_Main of Tk_Main procedure - * to source an application specific rc file into the interpreter at - * startup time. + * This function is typically invoked by Tcl_Main of Tk_Main function to + * source an application specific rc file into the interpreter at startup + * time. * * Results: * None. @@ -271,8 +268,8 @@ TclGetStartupScriptFileName() */ void -Tcl_SourceRCFile(interp) - Tcl_Interp *interp; /* Interpreter to source rc file into. */ +Tcl_SourceRCFile( + Tcl_Interp *interp) /* Interpreter to source rc file into. */ { Tcl_DString temp; CONST char *fileName; @@ -319,11 +316,11 @@ Tcl_SourceRCFile(interp) * Main program for tclsh and most other Tcl-based applications. * * Results: - * None. This procedure never returns (it exits the process when it's + * None. This function never returns (it exits the process when it's * done). * * Side effects: - * This procedure initializes the Tcl world and then starts interpreting + * This function initializes the Tcl world and then starts interpreting * commands; almost anything could happen, depending on the script being * interpreted. * @@ -331,12 +328,12 @@ Tcl_SourceRCFile(interp) */ void -Tcl_Main(argc, argv, appInitProc) - int argc; /* Number of arguments. */ - char **argv; /* Array of argument strings. */ - Tcl_AppInitProc *appInitProc; +Tcl_Main( + int argc, /* Number of arguments. */ + char **argv, /* Array of argument strings. */ + Tcl_AppInitProc *appInitProc) /* Application-specific initialization - * procedure to call after most initialization + * function to call after most initialization * but before starting to execute commands. */ { Tcl_Obj *path, *resultPtr, *argvPtr, *commandPtr = NULL; @@ -689,21 +686,21 @@ Tcl_Main(argc, argv, appInitProc) * * Tcl_SetMainLoop -- * - * Sets an alternative main loop procedure. + * Sets an alternative main loop function. * * Results: - * Returns the previously defined main loop procedure. + * Returns the previously defined main loop function. * * Side effects: - * This procedure will be called before Tcl exits, allowing for the + * This function will be called before Tcl exits, allowing for the * creation of an event loop. * *--------------------------------------------------------------- */ void -Tcl_SetMainLoop(proc) - Tcl_MainLoopProc *proc; +Tcl_SetMainLoop( + Tcl_MainLoopProc *proc) { mainLoopProc = proc; } @@ -713,7 +710,7 @@ Tcl_SetMainLoop(proc) * * StdinProc -- * - * This procedure is invoked by the event dispatcher whenever standard + * This function is invoked by the event dispatcher whenever standard * input becomes readable. It grabs the next line of input characters, * adds them to a command being assembled, and executes the command if * it's complete. @@ -729,9 +726,9 @@ Tcl_SetMainLoop(proc) /* ARGSUSED */ static void -StdinProc(clientData, mask) - ClientData clientData; /* The state of interactive cmd line */ - int mask; /* Not used. */ +StdinProc( + ClientData clientData, /* The state of interactive cmd line */ + int mask) /* Not used. */ { InteractiveState *isPtr = (InteractiveState *) clientData; Tcl_Channel chan = isPtr->input; @@ -838,9 +835,9 @@ StdinProc(clientData, mask) */ static void -Prompt(interp, promptPtr) - Tcl_Interp *interp; /* Interpreter to use for prompting. */ - PromptType *promptPtr; /* Points to type of prompt to print. Filled +Prompt( + Tcl_Interp *interp, /* Interpreter to use for prompting. */ + PromptType *promptPtr) /* Points to type of prompt to print. Filled * with PROMPT_NONE after a prompt is * printed. */ { |