Tcl Source Code

Check-in [4ee7449197]
Login
Core Home Timeline Branches Tags Tickets Wiki Clone or Download
Bounty program for improvements to Tcl and certain Tcl packages.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment: Made internal functions call Tcl_GetCwd & Tcl_Chdir Fixed broken tests due to adding encoding function.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | core-8-1-branch-old
Files: files | file ages | folders
SHA1: 4ee74491973ad0b7309bb440e441a673923a8b36
User & Date: rjohnson 1999-04-06 04:27:01
Context
1999-04-06
04:51
Fixed more tests. check-in: f6849d360d user: rjohnson tags: core-8-1-branch-old
04:27
Made internal functions call Tcl_GetCwd & Tcl_Chdir Fixed broken tests due to adding encoding funct... check-in: 4ee7449197 user: rjohnson tags: core-8-1-branch-old
03:19
decrease timeouts for DDE functions check-in: 25b9f0ef5e user: redman tags: core-8-1-branch-old
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclCmdAH.c. 

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335

 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCmdAH.c,v 1.1.2.10 1999/03/10 06:49:14 stanton Exp $
 */

#include "tclInt.h"
#include "tclPort.h"
#include <locale.h>

typedef int (StatProc)_ANSI_ARGS_((CONST char *path, struct stat *buf));
................................................................................
    } else {
	dirName = "~";
    }
    if (Tcl_TranslateFileName(interp, dirName, &ds) == NULL) {
	return TCL_ERROR;
    }

    result = TclpChdir(Tcl_DStringValue(&ds));
    Tcl_DStringFree(&ds);

    if (result != 0) {
	Tcl_AppendResult(interp, "couldn't change working directory to \"",
		dirName, "\": ", Tcl_PosixError(interp), (char *) NULL);
	return TCL_ERROR;
    }







|







 







|








7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335

 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCmdAH.c,v 1.1.2.11 1999/04/06 04:27:01 rjohnson Exp $
 */

#include "tclInt.h"
#include "tclPort.h"
#include <locale.h>

typedef int (StatProc)_ANSI_ARGS_((CONST char *path, struct stat *buf));
................................................................................
    } else {
	dirName = "~";
    }
    if (Tcl_TranslateFileName(interp, dirName, &ds) == NULL) {
	return TCL_ERROR;
    }

    result = Tcl_Chdir(Tcl_DStringValue(&ds));
    Tcl_DStringFree(&ds);

    if (result != 0) {
	Tcl_AppendResult(interp, "couldn't change working directory to \"",
		dirName, "\": ", Tcl_PosixError(interp), (char *) NULL);
	return TCL_ERROR;
    }

Changes to generic/tclCmdMZ.c. 

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104

 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCmdMZ.c,v 1.1.2.11 1999/04/05 22:20:27 rjohnson Exp $
 */

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

................................................................................
    Tcl_DString ds;

    if (objc != 1) {
	Tcl_WrongNumArgs(interp, 1, objv, NULL);
	return TCL_ERROR;
    }

    if (TclpGetCwd(interp, &ds) == NULL) {
	return TCL_ERROR;
    }
    Tcl_DStringResult(interp, &ds);
    return TCL_OK;
}
 
/*







|







 







|








9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104

 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCmdMZ.c,v 1.1.2.12 1999/04/06 04:27:01 rjohnson Exp $
 */

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

................................................................................
    Tcl_DString ds;

    if (objc != 1) {
	Tcl_WrongNumArgs(interp, 1, objv, NULL);
	return TCL_ERROR;
    }

    if (Tcl_GetCwd(interp, &ds) == NULL) {
	return TCL_ERROR;
    }
    Tcl_DStringResult(interp, &ds);
    return TCL_OK;
}
 
/*

Changes to generic/tclEncoding.c. 

4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
...
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
...
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
...
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611

 *	Contains the implementation of the encoding conversion package.
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclEncoding.c,v 1.1.2.10 1999/04/06 02:05:35 stanton Exp $
 */

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

typedef size_t (LengthProc)_ANSI_ARGS_((CONST char *src));

................................................................................
	Tcl_Obj **objv;
	Tcl_DString pwdString;
	char globArgString[10];

	objc = 0;
	Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv);

	TclpGetCwd(interp, &pwdString);

	for (i = 0; i < objc; i++) {
	    char *string;
	    int j, objc2, length;
	    Tcl_Obj **objv2;

	    string = Tcl_GetStringFromObj(objv[i], NULL);
................................................................................
	    /*
	     * TclGlob() changes the contents of globArgString, which causes
	     * a segfault if we pass in a pointer to non-writeable memory.
	     * TclGlob() puts its results directly into interp.
	     */

	    strcpy(globArgString, "*.enc");
	    if ((TclpChdir(string) == 0)
		    && (TclpChdir("encoding") == 0)
		    && (TclGlob(interp, globArgString, 0) == TCL_OK)) {
		objc2 = 0;

		Tcl_ListObjGetElements(NULL, Tcl_GetObjResult(interp), &objc2,
			&objv2);

		for (j = 0; j < objc2; j++) {
................................................................................
		    if (length > 0) {
			string[length] = '\0';
			Tcl_CreateHashEntry(&table, string, &dummy);
			string[length] = '.';
		    }
		}
	    }
	    TclpChdir(Tcl_DStringValue(&pwdString));
	}
	Tcl_DStringFree(&pwdString);
    }

    /*
     * Clear any values placed in the result by globbing.
     */







|







 







|







 







|
|







 







|








4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
...
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
...
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
...
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611

 *	Contains the implementation of the encoding conversion package.
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclEncoding.c,v 1.1.2.11 1999/04/06 04:27:02 rjohnson Exp $
 */

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

typedef size_t (LengthProc)_ANSI_ARGS_((CONST char *src));

................................................................................
	Tcl_Obj **objv;
	Tcl_DString pwdString;
	char globArgString[10];

	objc = 0;
	Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv);

	Tcl_GetCwd(interp, &pwdString);

	for (i = 0; i < objc; i++) {
	    char *string;
	    int j, objc2, length;
	    Tcl_Obj **objv2;

	    string = Tcl_GetStringFromObj(objv[i], NULL);
................................................................................
	    /*
	     * TclGlob() changes the contents of globArgString, which causes
	     * a segfault if we pass in a pointer to non-writeable memory.
	     * TclGlob() puts its results directly into interp.
	     */

	    strcpy(globArgString, "*.enc");
	    if ((Tcl_Chdir(string) == 0)
		    && (Tcl_Chdir("encoding") == 0)
		    && (TclGlob(interp, globArgString, 0) == TCL_OK)) {
		objc2 = 0;

		Tcl_ListObjGetElements(NULL, Tcl_GetObjResult(interp), &objc2,
			&objv2);

		for (j = 0; j < objc2; j++) {
................................................................................
		    if (length > 0) {
			string[length] = '\0';
			Tcl_CreateHashEntry(&table, string, &dummy);
			string[length] = '.';
		    }
		}
	    }
	    Tcl_Chdir(Tcl_DStringValue(&pwdString));
	}
	Tcl_DStringFree(&pwdString);
    }

    /*
     * Clear any values placed in the result by globbing.
     */

Changes to generic/tclUtil.c. 

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
....
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
....
2127
2128
2129
2130
2131
2132
2133

2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
....
2151
2152
2153
2154
2155
2156
2157


2158
2159
2160
2161
2162
2163

 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 *  RCS: @(#) $Id: tclUtil.c,v 1.1.2.9 1999/04/06 03:13:19 redman Exp $
 */

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

/*
 * The following variable holds the full path name of the binary
................................................................................
 */

CONST char *
Tcl_GetNameOfExecutable()
{
    return (tclExecutableName);
}




 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetCwd --
 *
 *	This function replaces the library version of getcwd().
................................................................................
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */


char *Tcl_GetCwd(interp, cwdPtr)
    Tcl_Interp *interp;
    Tcl_DString *cwdPtr;
{
    return TclpGetCwd(interp, cwdPtr);
}


 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_Chdir --
 *
 *	This function replaces the library version of chdir().
................................................................................
 *	See chdir() documentation.
 *
 * Side effects:
 *	See chdir() documentation.  
 *
 *----------------------------------------------------------------------
 */


int Tcl_Chdir(dirName)
    CONST char *dirName;
{
    return TclpChdir(dirName);
}








|







 







<
<
<
<







 







>
|





<
<







 







>
>
|






6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
....
2101
2102
2103
2104
2105
2106
2107




2108
2109
2110
2111
2112
2113
2114
....
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136


2137
2138
2139
2140
2141
2142
2143
....
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160

 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 *  RCS: @(#) $Id: tclUtil.c,v 1.1.2.10 1999/04/06 04:27:02 rjohnson Exp $
 */

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

/*
 * The following variable holds the full path name of the binary
................................................................................
 */

CONST char *
Tcl_GetNameOfExecutable()
{
    return (tclExecutableName);
}




 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetCwd --
 *
 *	This function replaces the library version of getcwd().
................................................................................
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_GetCwd(interp, cwdPtr)
    Tcl_Interp *interp;
    Tcl_DString *cwdPtr;
{
    return TclpGetCwd(interp, cwdPtr);
}


 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_Chdir --
 *
 *	This function replaces the library version of chdir().
................................................................................
 *	See chdir() documentation.
 *
 * Side effects:
 *	See chdir() documentation.  
 *
 *----------------------------------------------------------------------
 */

int
Tcl_Chdir(dirName)
    CONST char *dirName;
{
    return TclpChdir(dirName);
}

Changes to tests/interp.test. 

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
....
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692

#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: interp.test,v 1.1.2.10 1999/04/02 23:44:39 stanton Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# The set of hidden commands is platform dependent:

if {"$tcl_platform(platform)" == "macintosh"} {
    set hidden_cmds {beep cd echo exit fconfigure file glob load ls open pwd socket source}
} else {
    set hidden_cmds {cd exec exit fconfigure file glob load open pwd socket source}
}

foreach i [interp slaves] {
  interp delete $i
}

proc equiv {x} {return $x}
................................................................................
    lappend l [interp aliases a]
    lappend l [lsort [interp hidden a]]
    a alias bar {}
    lappend l [interp aliases a]
    lappend l [lsort [interp hidden a]]
    interp delete a
    set l
} {{cd exec exit fconfigure file glob load open pwd socket source} bar {cd exec exit fconfigure file glob load open pwd socket source} bar {bar cd exec exit fconfigure file glob load open pwd socket source} {} {cd exec exit fconfigure file glob load open pwd socket source}} 

test interp-23.3 {testing hiding vs aliases} {macOnly} {
    catch {interp delete a}
    interp create a -safe
    set l ""
    lappend l [lsort [interp hidden a]]
    a alias bar bar







|










|







 







|








6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
....
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692

#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: interp.test,v 1.1.2.11 1999/04/06 04:27:03 rjohnson Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# The set of hidden commands is platform dependent:

if {"$tcl_platform(platform)" == "macintosh"} {
    set hidden_cmds {beep cd echo exit fconfigure file glob load ls open pwd socket source}
} else {
    set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source}
}

foreach i [interp slaves] {
  interp delete $i
}

proc equiv {x} {return $x}
................................................................................
    lappend l [interp aliases a]
    lappend l [lsort [interp hidden a]]
    a alias bar {}
    lappend l [interp aliases a]
    lappend l [lsort [interp hidden a]]
    interp delete a
    set l
} {{cd encoding exec exit fconfigure file glob load open pwd socket source} bar {cd exec exit fconfigure file glob load open pwd socket source} bar {bar cd exec exit fconfigure file glob load open pwd socket source} {} {cd exec exit fconfigure file glob load open pwd socket source}} 

test interp-23.3 {testing hiding vs aliases} {macOnly} {
    catch {interp delete a}
    interp create a -safe
    set l ""
    lappend l [lsort [interp hidden a]]
    a alias bar bar

This page was generated in about 0.069s by Fossil 2.10 [eb804dc674] 2019-09-19 14:14:14