summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--doc/glob.n69
-rw-r--r--generic/tclEncoding.c4
-rw-r--r--generic/tclFileName.c501
-rw-r--r--generic/tclInt.decls8
-rw-r--r--generic/tclInt.h42
-rw-r--r--generic/tclIntDecls.h16
-rw-r--r--generic/tclStubInit.c3
-rw-r--r--mac/tclMacFile.c138
-rw-r--r--tests/fileName.test128
-rw-r--r--unix/tclUnixFile.c136
-rw-r--r--win/tclWinFile.c125
11 files changed, 1027 insertions, 143 deletions
diff --git a/doc/glob.n b/doc/glob.n
index d83d8fe..8d125d4 100644
--- a/doc/glob.n
+++ b/doc/glob.n
@@ -5,10 +5,10 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" RCS: @(#) $Id: glob.n,v 1.5 1999/11/19 06:33:58 hobbs Exp $
+'\" RCS: @(#) $Id: glob.n,v 1.6 1999/12/12 22:46:38 hobbs Exp $
'\"
.so man.macros
-.TH glob n 8.1 Tcl "Tcl Built-In Commands"
+.TH glob n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
@@ -26,11 +26,70 @@ of the \fIpattern\fR arguments.
If the initial arguments to \fBglob\fR start with \fB\-\fR then
they are treated as switches. The following switches are
currently supported:
-.TP 15
+.VS 8.3
+.TP
+\fB\-directory\fR \fIdirectory\fR
+Search for files which match the given patterns starting in the given
+\fIdirectory\fR. This allows searching of directories whose name
+contains glob-sensitive characters without the need to quote such
+characters explicitly. This option may not be used in conjunction with
+\fB\-path\fR.
+.TP
+\fB\-join\fR
+The remaining pattern arguments are treated as a single pattern
+obtained by joining the arguments with directory separators.
+.VE 8.3
+.TP
\fB\-nocomplain\fR
Allows an empty list to be returned without error; without this
switch an error is returned if the result list would be empty.
-.TP 15
+.VS 8.3
+.TP
+\fB\-path\fR \fIpathPrefix\fR
+Search for files with the given \fIpathPrefix\fR where the rest of the name
+matches the given patterns. This allows searching for files with names
+similar to a given file even when the names contain glob-sensitive
+characters. This option may not be used in conjunction with
+\fB\-directory\fR.
+.TP
+\fB\-types\fR \fItypeList\fR
+Only list files or directories which match \fItypeList\fR, where the items
+in the list have two forms. The first form is like the \-type option of
+the Unix find command:
+\fIb\fR (block special file),
+\fIc\fR (character special file),
+\fId\fR (directory),
+\fIf\fR (plain file),
+\fIl\fR (symbolic link),
+\fIp\fR (named pipe),
+or \fIs\fR (socket), where multiple types may be specified in the list.
+\fBGlob\fR will return all files which match at least one of the types given.
+.RS
+.PP
+The second form specifies types where all the types given must match.
+These are \fIr\fR, \fIw\fR, \fIx\fR as file permissions, and
+\fIreadonly\fR, \fIhidden\fR as special permission cases. On the
+Macintosh, MacOS types and creators are also supported, where any item
+which is four characters long is assumed to be a MacOS type
+(e.g. \fBTEXT\fR). Items which are of the form \fI{macintosh type XXXX}\fR
+or \fI{macintosh creator XXXX}\fR will match types or creators
+respectively. Unrecognised types, or specifications of multiple MacOS
+types/creators will signal an error.
+.PP
+The two forms may be mixed, so \fB\-types {d f r w}\fR will find all
+regular files OR directories that have both read AND write permissions.
+The following are equivalent:
+.RS
+.CS
+\fBglob \-type d *\fR
+\fBglob */\fR
+.CE
+.RE
+except that the first case doesn't return the trailing ``/'' and
+is more platform independent.
+.RE
+.VE 8.3
+.TP
\fB\-\|\-\fR
Marks the end of switches. The argument following this one will
be treated as a \fIpattern\fR even if it starts with a \fB\-\fR.
@@ -77,7 +136,6 @@ Unlike other Tcl commands that will accept both network and native
style names (see the \fBfilename\fR manual entry for details on how
native and network names are specified), the \fBglob\fR command only
accepts native names.
-.VS 8.1
.TP
\fBWindows\fR
.
@@ -88,7 +146,6 @@ directory of the user whose account information resides on the specified NT
domain server. Otherwise, user account information is obtained from
the local computer. On Windows 95 and 98, \fBglob\fR accepts patterns
like ``.../'' and ``..../'' for successively higher up parent directories.
-.VE
.SH KEYWORDS
exist, file, glob, pattern
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index ad86495..89453f5 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.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: tclEncoding.c,v 1.3 1999/12/02 02:03:22 redman Exp $
+ * RCS: @(#) $Id: tclEncoding.c,v 1.4 1999/12/12 22:46:41 hobbs Exp $
*/
#include "tclInt.h"
@@ -588,7 +588,7 @@ Tcl_GetEncodingNames(interp)
strcpy(globArgString, "*.enc");
if ((Tcl_Chdir(string) == 0)
&& (Tcl_Chdir("encoding") == 0)
- && (TclGlob(interp, globArgString, 0) == TCL_OK)) {
+ && (TclGlob(interp, globArgString, NULL, 0, NULL) == TCL_OK)) {
objc2 = 0;
Tcl_ListObjGetElements(NULL, Tcl_GetObjResult(interp), &objc2,
diff --git a/generic/tclFileName.c b/generic/tclFileName.c
index 06e83a3..cee1901 100644
--- a/generic/tclFileName.c
+++ b/generic/tclFileName.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: tclFileName.c,v 1.6 1999/04/16 00:46:46 stanton Exp $
+ * RCS: @(#) $Id: tclFileName.c,v 1.7 1999/12/12 22:46:42 hobbs Exp $
*/
#include "tclInt.h"
@@ -54,6 +54,15 @@ static Tcl_ThreadDataKey dataKey;
TclPlatformType tclPlatform = TCL_PLATFORM_UNIX;
/*
+ * The "globParameters" argument of the globbing functions is an
+ * or'ed combination of the following values:
+ */
+
+#define GLOBMODE_NO_COMPLAIN 1
+#define GLOBMODE_JOIN 2
+#define GLOBMODE_DIR 4
+
+/*
* Prototypes for local procedures defined in this file:
*/
@@ -1173,56 +1182,381 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- int index, i, noComplain, skip, length;
- char *string;
- static char *options[] = {"-nocomplain", "--", NULL};
- enum options {GLOB_NOCOMPLAIN, GLOB_LAST};
-
- noComplain = 0;
- for (skip = 1; skip < objc; skip++) {
- string = Tcl_GetString(objv[skip]);
- if (string[0] != '-') {
- break;
- }
- if (Tcl_GetIndexFromObj(interp, objv[skip], options, "switch",
- TCL_EXACT, &index) != TCL_OK) {
- return TCL_ERROR;
+ int index, i, globFlags, pathlength, length, join, dir, result;
+ char *string, *pathOrDir, *separators;
+ Tcl_Obj *typePtr, *resultPtr, *look;
+ Tcl_DString prefix, directory;
+ static char *options[] = {
+ "-directory", "-join", "-nocomplain", "-path", "-types", "--", NULL
+ };
+ enum options {
+ GLOB_DIR, GLOB_JOIN, GLOB_NOCOMPLAIN, GLOB_PATH, GLOB_TYPE, GLOB_LAST
+ };
+ enum pathDirOptions {PATH_NONE = -1 , PATH_GENERAL = 0, PATH_DIR = 1};
+ GlobTypeData *globTypes = NULL;
+
+ globFlags = 0;
+ join = 0;
+ dir = PATH_NONE;
+ pathOrDir = NULL;
+ typePtr = NULL;
+ resultPtr = Tcl_GetObjResult(interp);
+ for (i = 1; i < objc; i++) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index)
+ != TCL_OK) {
+ string = Tcl_GetStringFromObj(objv[i], &length);
+ if (string[0] == '-') {
+ /*
+ * It looks like the command contains an option so signal
+ * an error
+ */
+ return TCL_ERROR;
+ } else {
+ /*
+ * This clearly isn't an option; assume it's the first
+ * glob pattern. We must clear the error
+ */
+ Tcl_ResetResult(interp);
+ break;
+ }
}
- if (index == GLOB_NOCOMPLAIN) {
- noComplain = 1;
- } else {
- skip++;
- break;
+ switch (index) {
+ case GLOB_NOCOMPLAIN: /* -nocomplain */
+ globFlags |= GLOBMODE_NO_COMPLAIN;
+ break;
+ case GLOB_DIR: /* -dir */
+ if (i == (objc-1)) {
+ Tcl_AppendToObj(resultPtr,
+ "missing argument to \"-directory\"", -1);
+ return TCL_ERROR;
+ }
+ if (dir != -1) {
+ Tcl_AppendToObj(resultPtr,
+ "\"-directory\" cannot be used with \"-path\"",
+ -1);
+ return TCL_ERROR;
+ }
+ dir = PATH_DIR;
+ globFlags |= GLOBMODE_DIR;
+ pathOrDir = Tcl_GetStringFromObj(objv[i+1], &pathlength);
+ i++;
+ break;
+ case GLOB_JOIN: /* -join */
+ join = 1;
+ break;
+ case GLOB_PATH: /* -path */
+ if (i == (objc-1)) {
+ Tcl_AppendToObj(resultPtr,
+ "missing argument to \"-path\"", -1);
+ return TCL_ERROR;
+ }
+ if (dir != -1) {
+ Tcl_AppendToObj(resultPtr,
+ "\"-path\" cannot be used with \"-directory\"",
+ -1);
+ return TCL_ERROR;
+ }
+ dir = PATH_GENERAL;
+ pathOrDir = Tcl_GetStringFromObj(objv[i+1], &pathlength);
+ i++;
+ break;
+ case GLOB_TYPE: /* -types */
+ if (i == (objc-1)) {
+ Tcl_AppendToObj(resultPtr,
+ "missing argument to \"-types\"", -1);
+ return TCL_ERROR;
+ }
+ typePtr = objv[i+1];
+ if (Tcl_ListObjLength(interp, typePtr, &length) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ i++;
+ break;
+ case GLOB_LAST: /* -- */
+ i++;
+ goto endOfForLoop;
+ break;
}
}
- if (skip >= objc) {
+ endOfForLoop:
+ if (objc - i < 1) {
Tcl_WrongNumArgs(interp, 1, objv, "?switches? name ?name ...?");
return TCL_ERROR;
}
- for (i = skip; i < objc; i++) {
- string = Tcl_GetString(objv[i]);
- if (TclGlob(interp, string, noComplain) != TCL_OK) {
- return TCL_ERROR;
+ separators = NULL; /* lint. */
+ switch (tclPlatform) {
+ case TCL_PLATFORM_UNIX:
+ separators = "/";
+ break;
+ case TCL_PLATFORM_WINDOWS:
+ separators = "/\\:";
+ break;
+ case TCL_PLATFORM_MAC:
+ if ((pathOrDir != NULL) && (strchr(pathOrDir, ':') == NULL)) {
+ separators = "/";
+ } else {
+ separators = ":";
+ }
+ break;
+ }
+ if (dir == PATH_GENERAL) {
+ char *last;
+
+ /*
+ * Find the last path separator in the path
+ */
+ last = pathOrDir + pathlength;
+ for (; last != pathOrDir; last--) {
+ if (strchr(separators, *(last-1)) != NULL) {
+ break;
+ }
+ }
+ if (last == pathOrDir + pathlength) {
+ /* It's really a directory */
+ dir = 1;
+ } else {
+ Tcl_DString pref;
+ char *search, *find;
+ Tcl_DStringInit(&pref);
+ Tcl_DStringInit(&directory);
+ if (last == pathOrDir) {
+ /* The whole thing is a prefix */
+ Tcl_DStringAppend(&pref, pathOrDir, -1);
+ pathOrDir = NULL;
+ } else {
+ /* Have to split off the end */
+ Tcl_DStringAppend(&pref, last, pathOrDir+pathlength-last);
+ Tcl_DStringAppend(&directory, pathOrDir, last-pathOrDir-1);
+ pathOrDir = Tcl_DStringValue(&directory);
+ }
+ /* Need to quote 'prefix' */
+ Tcl_DStringInit(&prefix);
+ search = Tcl_DStringValue(&pref);
+ while ((find = (strpbrk(search, "\\[]*?{}"))) != NULL) {
+ Tcl_DStringAppend(&prefix, search, find-search);
+ Tcl_DStringAppend(&prefix, "\\", 1);
+ Tcl_DStringAppend(&prefix, find, 1);
+ search = find+1;
+ if (*search == '\0') {
+ break;
+ }
+ }
+ if (*search != '\0') {
+ Tcl_DStringAppend(&prefix, search, -1);
+ }
+ Tcl_DStringFree(&pref);
}
}
- if (noComplain == 0) {
- Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length);
- if (length == 0) {
- char *sep = "";
- Tcl_AppendResult(interp, "no files matched glob pattern",
- (objc == 2) ? " \"" : "s \"", (char *) NULL);
- for (i = skip; i < objc; i++) {
+ if (typePtr != NULL) {
+ /*
+ * The rest of the possible type arguments (except 'd') are
+ * platform specific. We don't complain when they are used
+ * on an incompatible platform.
+ */
+ Tcl_ListObjLength(interp, typePtr, &length);
+ globTypes = (GlobTypeData*) ckalloc(sizeof(GlobTypeData));
+ globTypes->type = 0;
+ globTypes->perm = 0;
+ globTypes->macType = NULL;
+ globTypes->macCreator = NULL;
+ while(--length >= 0) {
+ int len;
+ char *str;
+ Tcl_ListObjIndex(interp, typePtr, length, &look);
+ str = Tcl_GetStringFromObj(look, &len);
+ if (strcmp("readonly", str) == 0) {
+ globTypes->perm |= TCL_GLOB_PERM_RONLY;
+ } else if (strcmp("hidden", str) == 0) {
+ globTypes->perm |= TCL_GLOB_PERM_HIDDEN;
+ } else if (len == 1) {
+ switch (str[0]) {
+ case 'r':
+ globTypes->perm |= TCL_GLOB_PERM_R;
+ break;
+ case 'w':
+ globTypes->perm |= TCL_GLOB_PERM_W;
+ break;
+ case 'x':
+ globTypes->perm |= TCL_GLOB_PERM_X;
+ break;
+ case 'b':
+ globTypes->type |= TCL_GLOB_TYPE_BLOCK;
+ break;
+ case 'c':
+ globTypes->type |= TCL_GLOB_TYPE_CHAR;
+ break;
+ case 'd':
+ globTypes->type |= TCL_GLOB_TYPE_DIR;
+ break;
+ case 'p':
+ globTypes->type |= TCL_GLOB_TYPE_PIPE;
+ break;
+ case 'f':
+ globTypes->type |= TCL_GLOB_TYPE_FILE;
+ break;
+ case 'l':
+ globTypes->type |= TCL_GLOB_TYPE_LINK;
+ break;
+ case 's':
+ globTypes->type |= TCL_GLOB_TYPE_SOCK;
+ break;
+ default:
+ goto badTypesArg;
+ }
+ } else if (len == 4) {
+ /* This is assumed to be a MacOS file type */
+ if (globTypes->macType != NULL) {
+ goto badMacTypesArg;
+ }
+ globTypes->macType = look;
+ Tcl_IncrRefCount(look);
+ } else {
+ Tcl_Obj* item;
+ if ((Tcl_ListObjLength(NULL, look, &len) == TCL_OK) &&
+ (len == 3)) {
+ Tcl_ListObjIndex(interp, look, 0, &item);
+ if (!strcmp("macintosh", Tcl_GetString(item))) {
+ Tcl_ListObjIndex(interp, look, 1, &item);
+ if (!strcmp("type", Tcl_GetString(item))) {
+ Tcl_ListObjIndex(interp, look, 2, &item);
+ if (globTypes->macType != NULL) {
+ goto badMacTypesArg;
+ }
+ globTypes->macType = item;
+ Tcl_IncrRefCount(item);
+ continue;
+ } else if (!strcmp("creator", Tcl_GetString(item))) {
+ Tcl_ListObjIndex(interp, look, 2, &item);
+ if (globTypes->macCreator != NULL) {
+ goto badMacTypesArg;
+ }
+ globTypes->macCreator = item;
+ Tcl_IncrRefCount(item);
+ continue;
+ }
+ }
+ }
+ /*
+ * Error cases
+ */
+ badTypesArg:
+ Tcl_AppendToObj(resultPtr, "bad argument to \"-types\": ", -1);
+ Tcl_AppendObjToObj(resultPtr, look);
+ result = TCL_ERROR;
+ goto endOfGlob;
+ badMacTypesArg:
+ Tcl_AppendToObj(resultPtr,
+ "only one MacOS type or creator argument to \"-types\" allowed", -1);
+ result = TCL_ERROR;
+ goto endOfGlob;
+ }
+ }
+ }
+
+ /*
+ * Now we perform the actual glob below. This may involve joining
+ * together the pattern arguments, dealing with particular file types
+ * etc. We use a 'goto' to ensure we free any memory allocated along
+ * the way.
+ */
+ objc -= i;
+ objv += i;
+ /*
+ * We re-retrieve this, in case it was changed in
+ * the Tcl_ResetResult above
+ */
+ resultPtr = Tcl_GetObjResult(interp);
+ result = TCL_OK;
+ if (join) {
+ if (dir != PATH_GENERAL) {
+ Tcl_DStringInit(&prefix);
+ }
+ for (i = 0; i < objc; i++) {
+ string = Tcl_GetStringFromObj(objv[i], &length);
+ Tcl_DStringAppend(&prefix, string, length);
+ if (i != objc -1) {
+ Tcl_DStringAppend(&prefix, separators, 1);
+ }
+ }
+ if (TclGlob(interp, Tcl_DStringValue(&prefix), pathOrDir,
+ globFlags, globTypes) != TCL_OK) {
+ result = TCL_ERROR;
+ goto endOfGlob;
+ }
+ } else {
+ if (dir == PATH_GENERAL) {
+ Tcl_DString str;
+ for (i = 0; i < objc; i++) {
+ Tcl_DStringInit(&str);
+ if (dir == PATH_GENERAL) {
+ Tcl_DStringAppend(&str, Tcl_DStringValue(&prefix),
+ Tcl_DStringLength(&prefix));
+ }
+ string = Tcl_GetStringFromObj(objv[i], &length);
+ Tcl_DStringAppend(&str, string, length);
+ if (TclGlob(interp, Tcl_DStringValue(&str), pathOrDir,
+ globFlags, globTypes) != TCL_OK) {
+ result = TCL_ERROR;
+ Tcl_DStringFree(&str);
+ goto endOfGlob;
+ }
+ }
+ Tcl_DStringFree(&str);
+ } else {
+ for (i = 0; i < objc; i++) {
string = Tcl_GetString(objv[i]);
- Tcl_AppendResult(interp, sep, string, (char *) NULL);
- sep = " ";
+ if (TclGlob(interp, string, pathOrDir,
+ globFlags, globTypes) != TCL_OK) {
+ result = TCL_ERROR;
+ goto endOfGlob;
+ }
+ }
+ }
+ }
+ if ((globFlags & GLOBMODE_NO_COMPLAIN) == 0) {
+ if (Tcl_ListObjLength(interp, Tcl_GetObjResult(interp),
+ &length) != TCL_OK) {
+ /* This should never happen. Maybe we should be more dramatic */
+ result = TCL_ERROR;
+ goto endOfGlob;
+ }
+ if (length == 0) {
+ Tcl_AppendResult(interp, "no files matched glob pattern",
+ (join || (objc == 1)) ? " \"" : "s \"", (char *) NULL);
+ if (join) {
+ Tcl_AppendResult(interp, Tcl_DStringValue(&prefix),
+ (char *) NULL);
+ } else {
+ char *sep = "";
+ for (i = 0; i < objc; i++) {
+ string = Tcl_GetString(objv[i]);
+ Tcl_AppendResult(interp, sep, string, (char *) NULL);
+ sep = " ";
+ }
}
Tcl_AppendResult(interp, "\"", (char *) NULL);
- return TCL_ERROR;
+ result = TCL_ERROR;
}
}
- return TCL_OK;
+ endOfGlob:
+ if (join || (dir == PATH_GENERAL)) {
+ Tcl_DStringFree(&prefix);
+ if (dir == PATH_GENERAL) {
+ Tcl_DStringFree(&directory);
+ }
+ }
+ if (globTypes != NULL) {
+ if (globTypes->macType != NULL) {
+ Tcl_DecrRefCount(globTypes->macType);
+ }
+ if (globTypes->macCreator != NULL) {
+ Tcl_DecrRefCount(globTypes->macCreator);
+ }
+ ckfree((char *) globTypes);
+ }
+ return result;
}
/*
@@ -1249,16 +1583,19 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv)
/* ARGSUSED */
int
-TclGlob(interp, pattern, noComplain)
+TclGlob(interp, pattern, unquotedPrefix, globFlags, types)
Tcl_Interp *interp; /* Interpreter for returning error message
* or appending list of matching file names. */
char *pattern; /* Glob pattern to match. Must not refer
* to a static string. */
- int noComplain; /* Flag to turn off storing error messages
- * in interp. */
+ char *unquotedPrefix; /* Prefix to glob pattern, if non-null, which
+ * is considered literally. May be static. */
+ int globFlags; /* Stores or'ed combination of flags */
+ GlobTypeData *types; /* Struct containing acceptable types.
+ * May be NULL. */
{
char *separators;
- char *head, *tail;
+ char *head, *tail, *start;
char c;
int result;
Tcl_DString buffer;
@@ -1278,19 +1615,22 @@ TclGlob(interp, pattern, noComplain)
}
Tcl_DStringInit(&buffer);
+ if (unquotedPrefix != NULL) {
+ start = unquotedPrefix;
+ } else {
+ start = pattern;
+ }
/*
* Perform tilde substitution, if needed.
*/
- if (pattern[0] == '~') {
- char *p;
-
+ if (start[0] == '~') {
+
/*
* Find the first path separator after the tilde.
*/
-
- for (tail = pattern; *tail != '\0'; tail++) {
+ for (tail = start; *tail != '\0'; tail++) {
if (*tail == '\\') {
if (strchr(separators, tail[1]) != NULL) {
break;
@@ -1307,20 +1647,29 @@ TclGlob(interp, pattern, noComplain)
c = *tail;
*tail = '\0';
- p = strpbrk(pattern+1, "\\[]*?{}");
- if (p == NULL) {
- head = DoTildeSubst(interp, pattern+1, &buffer);
+ /*
+ * I don't think we need to worry about special characters in
+ * the user name anymore (Vince Darley, June 1999), since the
+ * new code is designed to handle special chars.
+ */
+ #ifndef NOT_NEEDED_ANYMORE
+ head = DoTildeSubst(interp, start+1, &buffer);
+ #else
+
+ if (strpbrk(start+1, "\\[]*?{}") == NULL) {
+ head = DoTildeSubst(interp, start+1, &buffer);
} else {
- if (!noComplain) {
+ if (!(globFlags & GLOBMODE_NO_COMPLAIN)) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "globbing characters not ",
"supported in user names", (char *) NULL);
}
head = NULL;
}
+ #endif
*tail = c;
if (head == NULL) {
- if (noComplain) {
+ if (globFlags & GLOBMODE_NO_COMPLAIN) {
/*
* We should in fact pass down the nocomplain flag
* or save the interp result or use another mechanism
@@ -1338,14 +1687,33 @@ TclGlob(interp, pattern, noComplain)
if (head != Tcl_DStringValue(&buffer)) {
Tcl_DStringAppend(&buffer, head, -1);
}
+ if (unquotedPrefix != NULL) {
+ Tcl_DStringAppend(&buffer, tail, -1);
+ tail = pattern;
+ }
} else {
tail = pattern;
+ if (unquotedPrefix != NULL) {
+ Tcl_DStringAppend(&buffer,unquotedPrefix,-1);
+ }
+ }
+ /*
+ * If the prefix is a directory, make sure it ends in a directory
+ * separator.
+ */
+ if (unquotedPrefix != NULL) {
+ if (globFlags & GLOBMODE_DIR) {
+ c = Tcl_DStringValue(&buffer)[Tcl_DStringLength(&buffer)-1];
+ if (strchr(separators, c) == NULL) {
+ Tcl_DStringAppend(&buffer,separators,1);
+ }
+ }
}
- result = TclDoGlob(interp, separators, &buffer, tail);
+ result = TclDoGlob(interp, separators, &buffer, tail, types);
Tcl_DStringFree(&buffer);
if (result != TCL_OK) {
- if (noComplain) {
+ if (globFlags & GLOBMODE_NO_COMPLAIN) {
Tcl_ResetResult(interp);
return TCL_OK;
}
@@ -1413,7 +1781,11 @@ SkipToChar(stringPtr, match)
* This recursive procedure forms the heart of the globbing
* code. It performs a depth-first traversal of the tree
* given by the path name to be globbed. The directory and
- * remainder are assumed to be native format paths.
+ * remainder are assumed to be native format paths. The prefix
+ * contained in 'headPtr' is not used as a glob pattern, simply
+ * as a path specifier, so it can contain unquoted glob-sensitive
+ * characters (if the directories to which it points contain
+ * such strange characters).
*
* Results:
* The return value is a standard Tcl result indicating whether
@@ -1429,7 +1801,7 @@ SkipToChar(stringPtr, match)
*/
int
-TclDoGlob(interp, separators, headPtr, tail)
+TclDoGlob(interp, separators, headPtr, tail, types)
Tcl_Interp *interp; /* Interpreter to use for error reporting
* (e.g. unmatched brace). */
char *separators; /* String containing separator characters
@@ -1438,11 +1810,14 @@ TclDoGlob(interp, separators, headPtr, tail)
Tcl_DString *headPtr; /* Completely expanded prefix. */
char *tail; /* The unexpanded remainder of the path.
* Must not be a pointer to a static string. */
+ GlobTypeData *types; /* List object containing list of acceptable types.
+ * May be NULL. */
{
int baseLength, quoted, count;
int result = TCL_OK;
char *name, *p, *openBrace, *closeBrace, *firstSpecialChar, savedChar;
char lastChar = 0;
+
int length = Tcl_DStringLength(headPtr);
if (length > 0) {
@@ -1594,7 +1969,7 @@ TclDoGlob(interp, separators, headPtr, tail)
Tcl_DStringAppend(&newName, element, p-element);
Tcl_DStringAppend(&newName, closeBrace+1, -1);
result = TclDoGlob(interp, separators,
- headPtr, Tcl_DStringValue(&newName));
+ headPtr, Tcl_DStringValue(&newName), types);
if (result != TCL_OK) {
break;
}
@@ -1636,11 +2011,11 @@ TclDoGlob(interp, separators, headPtr, tail)
* are more characters to be processed.
*/
- return TclpMatchFiles(interp, separators, headPtr, tail, p);
+ return TclpMatchFilesTypes(interp, separators, headPtr, tail, p, types);
}
Tcl_DStringAppend(headPtr, tail, p-tail);
if (*p != '\0') {
- return TclDoGlob(interp, separators, headPtr, p);
+ return TclDoGlob(interp, separators, headPtr, p, types);
}
/*
@@ -1657,9 +2032,11 @@ TclDoGlob(interp, separators, headPtr, tail)
name = Tcl_DStringValue(headPtr);
if (TclpAccess(name, F_OK) == 0) {
if ((name[1] != '\0') && (strchr(name+1, ':') == NULL)) {
- Tcl_AppendElement(interp, name + 1);
+ Tcl_ListObjAppendElement(interp, Tcl_GetObjResult(interp),
+ Tcl_NewStringObj(name + 1,-1));
} else {
- Tcl_AppendElement(interp, name);
+ Tcl_ListObjAppendElement(interp, Tcl_GetObjResult(interp),
+ Tcl_NewStringObj(name,-1));
}
}
break;
@@ -1696,7 +2073,8 @@ TclDoGlob(interp, separators, headPtr, tail)
}
}
if (exists) {
- Tcl_AppendElement(interp, name);
+ Tcl_ListObjAppendElement(interp, Tcl_GetObjResult(interp),
+ Tcl_NewStringObj(name,-1));
}
break;
}
@@ -1710,7 +2088,8 @@ TclDoGlob(interp, separators, headPtr, tail)
}
name = Tcl_DStringValue(headPtr);
if (TclpAccess(name, F_OK) == 0) {
- Tcl_AppendElement(interp, name);
+ Tcl_ListObjAppendElement(interp, Tcl_GetObjResult(interp),
+ Tcl_NewStringObj(name,-1));
}
break;
}
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index f535e71..e649022 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -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: tclInt.decls,v 1.18 1999/12/02 02:03:25 redman Exp $
+# RCS: @(#) $Id: tclInt.decls,v 1.19 1999/12/12 22:46:42 hobbs Exp $
library tcl
@@ -73,7 +73,7 @@ declare 12 generic {
}
declare 13 generic {
int TclDoGlob(Tcl_Interp *interp, char *separators, \
- Tcl_DString *headPtr, char *tail)
+ Tcl_DString *headPtr, char *tail, GlobTypeData *types)
}
declare 14 generic {
void TclDumpMemoryInfo(FILE *outFile)
@@ -598,6 +598,10 @@ declare 158 generic {
declare 159 generic {
char *TclGetStartupScriptFileName(void)
}
+declare 160 generic {
+ int TclpMatchFilesTypes(Tcl_Interp *interp, char *separators, \
+ Tcl_DString *dirPtr, char *pattern, char *tail, GlobTypeData *types)
+}
##############################################################################
diff --git a/generic/tclInt.h b/generic/tclInt.h
index f96ae87..92f8985 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.38 1999/12/04 06:15:41 hobbs Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.39 1999/12/12 22:46:42 hobbs Exp $
*/
#ifndef _TCLINT
@@ -1480,6 +1480,41 @@ typedef int (*TclObjCmdProcType) _ANSI_ARGS_((ClientData clientData,
typedef struct TclpTime_t_ *TclpTime_t;
+/*
+ * The following structure is used to pass glob type data amongst
+ * the various glob routines and TclpMatchFilesTypes. Currently
+ * most of the fields are ignored. However they will be used in
+ * a future release to implement glob's ability to find files
+ * of particular types/permissions/etc only.
+ */
+typedef struct GlobTypeData {
+ /* Corresponds to bcdpfls as in 'find -t' */
+ int type;
+ /* Corresponds to file permissions */
+ int perm;
+ /* Acceptable mac type */
+ Tcl_Obj* macType;
+ /* Acceptable mac creator */
+ Tcl_Obj* macCreator;
+} GlobTypeData;
+
+/*
+ * type and permission definitions for glob command
+ */
+#define TCL_GLOB_TYPE_BLOCK (1<<0)
+#define TCL_GLOB_TYPE_CHAR (1<<1)
+#define TCL_GLOB_TYPE_DIR (1<<2)
+#define TCL_GLOB_TYPE_PIPE (1<<3)
+#define TCL_GLOB_TYPE_FILE (1<<4)
+#define TCL_GLOB_TYPE_LINK (1<<5)
+#define TCL_GLOB_TYPE_SOCK (1<<6)
+
+#define TCL_GLOB_PERM_RONLY (1<<0)
+#define TCL_GLOB_PERM_HIDDEN (1<<1)
+#define TCL_GLOB_PERM_R (1<<2)
+#define TCL_GLOB_PERM_W (1<<3)
+#define TCL_GLOB_PERM_X (1<<4)
+
/*
*----------------------------------------------------------------
* Variables shared among Tcl modules but not used by the outside world.
@@ -1570,7 +1605,7 @@ EXTERN void TclDeleteVars _ANSI_ARGS_((Interp *iPtr,
Tcl_HashTable *tablePtr));
EXTERN int TclDoGlob _ANSI_ARGS_((Tcl_Interp *interp,
char *separators, Tcl_DString *headPtr,
- char *tail));
+ char *tail, GlobTypeData *types));
EXTERN void TclDumpMemoryInfo _ANSI_ARGS_((FILE *outFile));
EXTERN void TclExpandTokenArray _ANSI_ARGS_((
Tcl_Parse *parsePtr));
@@ -1636,7 +1671,8 @@ EXTERN int TclGetOpenMode _ANSI_ARGS_((Tcl_Interp *interp,
EXTERN Tcl_Command TclGetOriginalCommand _ANSI_ARGS_((
Tcl_Command command));
EXTERN int TclGlob _ANSI_ARGS_((Tcl_Interp *interp,
- char *pattern, int noComplain));
+ char *pattern, char *unquotedPrefix,
+ int globFlags, GlobTypeData* types));
EXTERN int TclGlobalInvoke _ANSI_ARGS_((Tcl_Interp *interp,
int argc, char **argv, int flags));
EXTERN int TclGuessPackageName _ANSI_ARGS_((char *fileName,
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index 7e96fee..082066b 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIntDecls.h,v 1.18 1999/12/02 02:03:26 redman Exp $
+ * RCS: @(#) $Id: tclIntDecls.h,v 1.19 1999/12/12 22:46:42 hobbs Exp $
*/
#ifndef _TCLINTDECLS
@@ -89,7 +89,7 @@ EXTERN void TclDeleteVars _ANSI_ARGS_((Interp * iPtr,
/* 13 */
EXTERN int TclDoGlob _ANSI_ARGS_((Tcl_Interp * interp,
char * separators, Tcl_DString * headPtr,
- char * tail));
+ char * tail, GlobTypeData * types));
/* 14 */
EXTERN void TclDumpMemoryInfo _ANSI_ARGS_((FILE * outFile));
/* Slot 15 is reserved */
@@ -524,6 +524,11 @@ EXTERN void TclSetStartupScriptFileName _ANSI_ARGS_((
char * filename));
/* 159 */
EXTERN char * TclGetStartupScriptFileName _ANSI_ARGS_((void));
+/* 160 */
+EXTERN int TclpMatchFilesTypes _ANSI_ARGS_((Tcl_Interp * interp,
+ char * separators, Tcl_DString * dirPtr,
+ char * pattern, char * tail,
+ GlobTypeData * types));
typedef struct TclIntStubs {
int magic;
@@ -558,7 +563,7 @@ typedef struct TclIntStubs {
int (*tclCreateProc) _ANSI_ARGS_((Tcl_Interp * interp, Namespace * nsPtr, char * procName, Tcl_Obj * argsPtr, Tcl_Obj * bodyPtr, Proc ** procPtrPtr)); /* 10 */
void (*tclDeleteCompiledLocalVars) _ANSI_ARGS_((Interp * iPtr, CallFrame * framePtr)); /* 11 */
void (*tclDeleteVars) _ANSI_ARGS_((Interp * iPtr, Tcl_HashTable * tablePtr)); /* 12 */
- int (*tclDoGlob) _ANSI_ARGS_((Tcl_Interp * interp, char * separators, Tcl_DString * headPtr, char * tail)); /* 13 */
+ int (*tclDoGlob) _ANSI_ARGS_((Tcl_Interp * interp, char * separators, Tcl_DString * headPtr, char * tail, GlobTypeData * types)); /* 13 */
void (*tclDumpMemoryInfo) _ANSI_ARGS_((FILE * outFile)); /* 14 */
void *reserved15;
void (*tclExprFloatError) _ANSI_ARGS_((Tcl_Interp * interp, double value)); /* 16 */
@@ -721,6 +726,7 @@ typedef struct TclIntStubs {
Var * (*tclVarTraceExists) _ANSI_ARGS_((Tcl_Interp * interp, char * varName)); /* 157 */
void (*tclSetStartupScriptFileName) _ANSI_ARGS_((char * filename)); /* 158 */
char * (*tclGetStartupScriptFileName) _ANSI_ARGS_((void)); /* 159 */
+ int (*tclpMatchFilesTypes) _ANSI_ARGS_((Tcl_Interp * interp, char * separators, Tcl_DString * dirPtr, char * pattern, char * tail, GlobTypeData * types)); /* 160 */
} TclIntStubs;
#ifdef __cplusplus
@@ -1370,6 +1376,10 @@ extern TclIntStubs *tclIntStubsPtr;
#define TclGetStartupScriptFileName \
(tclIntStubsPtr->tclGetStartupScriptFileName) /* 159 */
#endif
+#ifndef TclpMatchFilesTypes
+#define TclpMatchFilesTypes \
+ (tclIntStubsPtr->tclpMatchFilesTypes) /* 160 */
+#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 23f916b..8a2f372 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.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: tclStubInit.c,v 1.29 1999/12/02 02:03:27 redman Exp $
+ * RCS: @(#) $Id: tclStubInit.c,v 1.30 1999/12/12 22:46:43 hobbs Exp $
*/
#include "tclInt.h"
@@ -235,6 +235,7 @@ TclIntStubs tclIntStubs = {
TclVarTraceExists, /* 157 */
TclSetStartupScriptFileName, /* 158 */
TclGetStartupScriptFileName, /* 159 */
+ TclpMatchFilesTypes, /* 160 */
};
TclIntPlatStubs tclIntPlatStubs = {
diff --git a/mac/tclMacFile.c b/mac/tclMacFile.c
index b3175d9..b6ae7a2 100644
--- a/mac/tclMacFile.c
+++ b/mac/tclMacFile.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: tclMacFile.c,v 1.8 1999/08/10 04:21:35 jingham Exp $
+ * RCS: @(#) $Id: tclMacFile.c,v 1.9 1999/12/12 22:46:45 hobbs Exp $
*/
/*
@@ -102,7 +102,7 @@ TclpFindExecutable(
/*
*----------------------------------------------------------------------
*
- * TclpMatchFiles --
+ * TclpMatchFilesTypes --
*
* This routine is used by the globbing code to search a
* directory for all files which match a given pattern.
@@ -120,18 +120,20 @@ TclpFindExecutable(
*---------------------------------------------------------------------- */
int
-TclpMatchFiles(
+TclpMatchFilesTypes(
Tcl_Interp *interp, /* Interpreter to receive results. */
char *separators, /* Directory separators to pass to TclDoGlob. */
Tcl_DString *dirPtr, /* Contains path to directory to search. */
char *pattern, /* Pattern to match against. */
- char *tail) /* Pointer to end of pattern. Tail must
+ char *tail, /* Pointer to end of pattern. Tail must
* point to a location in pattern and must
* not be static.*/
+ GlobTypeData *types) /* Object containing list of acceptable types.
+ * May be NULL. */
{
- char *patternEnd = tail;
+ char *fname, *patternEnd = tail;
char savedChar;
- int result = TCL_OK;
+ int fnameLen, result = TCL_OK;
int baseLength = Tcl_DStringLength(dirPtr);
CInfoPBRec pb;
OSErr err;
@@ -141,17 +143,21 @@ TclpMatchFiles(
short itemIndex;
Str255 fileName;
Tcl_DString fileString;
+ Tcl_Obj *resultPtr;
+ OSType okType = 0;
+ OSType okCreator = 0;
/*
* Make sure that the directory part of the name really is a
* directory.
*/
- Tcl_UtfToExternalDString(NULL, dirPtr->string, dirPtr->length, &fileString);
-
+ Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(dirPtr),
+ Tcl_DStringLength(dirPtr), &fileString);
+
FSpLocationFromPath(fileString.length, fileString.string, &dirSpec);
Tcl_DStringFree(&fileString);
-
+
err = FSpGetDirectoryID(&dirSpec, &dirID, &isDirectory);
if ((err != noErr) || !isDirectory) {
return TCL_OK;
@@ -165,7 +171,7 @@ TclpMatchFiles(
pb.hFileInfo.ioDirID = dirID;
pb.hFileInfo.ioNamePtr = (StringPtr) fileName;
pb.hFileInfo.ioFDirIndex = itemIndex = 1;
-
+
/*
* Clean up the end of the pattern and the tail pointer. Leave
* the tail pointing to the first character after the path separator
@@ -184,6 +190,16 @@ TclpMatchFiles(
savedChar = *patternEnd;
*patternEnd = '\0';
+ resultPtr = Tcl_GetObjResult(interp);
+ if (types != NULL) {
+ if (types->macType != NULL) {
+ Tcl_GetOSTypeFromObj(NULL, types->macType, &okType);
+ }
+ if (types->macCreator != NULL) {
+ Tcl_GetOSTypeFromObj(NULL, types->macCreator, &okCreator);
+ }
+ }
+
while (1) {
pb.hFileInfo.ioFDirIndex = itemIndex;
pb.hFileInfo.ioDirID = dirID;
@@ -204,16 +220,84 @@ TclpMatchFiles(
if (Tcl_StringMatch(Tcl_DStringValue(&fileString), pattern)) {
Tcl_DStringSetLength(dirPtr, baseLength);
Tcl_DStringAppend(dirPtr, Tcl_DStringValue(&fileString), -1);
+ fname = Tcl_DStringValue(dirPtr);
+ fnameLen = Tcl_DStringLength(dirPtr);
if (tail == NULL) {
- if ((dirPtr->length > 1) &&
- (strchr(dirPtr->string+1, ':') == NULL)) {
- Tcl_AppendElement(interp, dirPtr->string+1);
- } else {
- Tcl_AppendElement(interp, dirPtr->string);
+ int typeOk = 1;
+ if (types != NULL) {
+ if (types->perm != 0) {
+ if (
+ ((types->perm & TCL_GLOB_PERM_RONLY) &&
+ !(pb.hFileInfo.ioFlAttrib & 1)) ||
+ ((types->perm & TCL_GLOB_PERM_HIDDEN) &&
+ !(pb.hFileInfo.ioFlFndrInfo.fdFlags &
+ kIsInvisible)) ||
+ ((types->perm & TCL_GLOB_PERM_R) &&
+ (TclpAccess(fname, R_OK) != 0)) ||
+ ((types->perm & TCL_GLOB_PERM_W) &&
+ (TclpAccess(fname, W_OK) != 0)) ||
+ ((types->perm & TCL_GLOB_PERM_X) &&
+ (TclpAccess(fname, X_OK) != 0))
+ ) {
+ typeOk = 0;
+ }
+ }
+ if (typeOk == 1 && types->type != 0) {
+ struct stat buf;
+ /*
+ * We must match at least one flag to be listed
+ */
+ typeOk = 0;
+ if (TclpLstat(fname, &buf) >= 0) {
+ /*
+ * In order bcdpfls as in 'find -t'
+ */
+ if (
+ ((types->type & TCL_GLOB_TYPE_BLOCK) &&
+ S_ISBLK(buf.st_mode)) ||
+ ((types->type & TCL_GLOB_TYPE_CHAR) &&
+ S_ISCHR(buf.st_mode)) ||
+ ((types->type & TCL_GLOB_TYPE_DIR) &&
+ S_ISDIR(buf.st_mode)) ||
+ ((types->type & TCL_GLOB_TYPE_PIPE) &&
+ S_ISFIFO(buf.st_mode)) ||
+ ((types->type & TCL_GLOB_TYPE_FILE) &&
+ S_ISREG(buf.st_mode))
+#ifdef S_ISLNK
+ || ((types->type & TCL_GLOB_TYPE_LINK) &&
+ S_ISLNK(buf.st_mode))
+#endif
+#ifdef S_ISSOCK
+ || ((types->type & TCL_GLOB_TYPE_SOCK) &&
+ S_ISSOCK(buf.st_mode))
+#endif
+ ) {
+ typeOk = 1;
+ }
+ } else {
+ /* Posix error occurred */
+ }
+ }
+ if (typeOk && (
+ ((okType != 0) && (okType !=
+ pb.hFileInfo.ioFlFndrInfo.fdType)) ||
+ ((okCreator != 0) && (okCreator !=
+ pb.hFileInfo.ioFlFndrInfo.fdCreator)))) {
+ typeOk = 0;
+ }
+ }
+ if (typeOk) {
+ if ((fnameLen > 1) && (strchr(fname+1, ':') == NULL)) {
+ Tcl_ListObjAppendElement(interp, resultPtr,
+ Tcl_NewStringObj(fname+1, fnameLen-1));
+ } else {
+ Tcl_ListObjAppendElement(interp, resultPtr,
+ Tcl_NewStringObj(fname, fnameLen));
+ }
}
} else if ((pb.hFileInfo.ioFlAttrib & ioDirMask) != 0) {
Tcl_DStringAppend(dirPtr, ":", 1);
- result = TclDoGlob(interp, separators, dirPtr, tail);
+ result = TclDoGlob(interp, separators, dirPtr, tail, types);
if (result != TCL_OK) {
Tcl_DStringFree(&fileString);
break;
@@ -221,7 +305,6 @@ TclpMatchFiles(
}
}
Tcl_DStringFree(&fileString);
-
itemIndex++;
}
*patternEnd = savedChar;
@@ -229,6 +312,25 @@ TclpMatchFiles(
return result;
}
+/*
+ * TclpMatchFiles --
+ *
+ * This function is now obsolete. Call the above function
+ * 'TclpMatchFilesTypes' instead.
+ */
+int
+TclpMatchFiles(
+ Tcl_Interp *interp, /* Interpreter to receive results. */
+ char *separators, /* Directory separators to pass to TclDoGlob. */
+ Tcl_DString *dirPtr, /* Contains path to directory to search. */
+ char *pattern, /* Pattern to match against. */
+ char *tail) /* Pointer to end of pattern. Tail must
+ * point to a location in pattern and must
+ * not be static.*/
+{
+ return TclpMatchFilesTypes(interp,separators,dirPtr,pattern,tail,NULL);
+}
+
/*
*----------------------------------------------------------------------
*
@@ -918,4 +1020,4 @@ TclMacChmod(
}
return 0;
-} \ No newline at end of file
+}
diff --git a/tests/fileName.test b/tests/fileName.test
index d93c93f..91c5cda 100644
--- a/tests/fileName.test
+++ b/tests/fileName.test
@@ -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: fileName.test,v 1.5 1999/07/01 17:36:18 jenn Exp $
+# RCS: @(#) $Id: fileName.test,v 1.6 1999/12/12 22:46:47 hobbs Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -1048,10 +1048,10 @@ test filename-11.1 {Tcl_GlobCmd} {
} {1 {wrong # args: should be "glob ?switches? name ?name ...?"}}
test filename-11.2 {Tcl_GlobCmd} {
list [catch {glob -gorp} msg] $msg
-} {1 {bad switch "-gorp": must be -nocomplain or --}}
+} {1 {bad option "-gorp": must be -directory, -join, -nocomplain, -path, -types, or --}}
test filename-11.3 {Tcl_GlobCmd} {
list [catch {glob -nocomplai} msg] $msg
-} {1 {bad switch "-nocomplai": must be -nocomplain or --}}
+} {1 {wrong # args: should be "glob ?switches? name ?name ...?"}}
test filename-11.4 {Tcl_GlobCmd} {
list [catch {glob -nocomplain} msg] $msg
} {1 {wrong # args: should be "glob ?switches? name ?name ...?"}}
@@ -1063,14 +1063,14 @@ test filename-11.6 {Tcl_GlobCmd} {
} {1 {user "xyqrszzz" doesn't exist}}
test filename-11.7 {Tcl_GlobCmd} {
list [catch {glob -- -nocomplain} msg] $msg
-} {1 {no files matched glob patterns "-nocomplain"}}
+} {1 {no files matched glob pattern "-nocomplain"}}
test filename-11.8 {Tcl_GlobCmd} {
list [catch {glob -nocomplain -- -nocomplain} msg] $msg
} {0 {}}
test filename-11.9 {Tcl_GlobCmd} {
testsetplatform unix
list [catch {glob ~\\xyqrszzz/bar} msg] $msg
-} {1 {globbing characters not supported in user names}}
+} {1 {user "\xyqrszzz" doesn't exist}}
test filename-11.10 {Tcl_GlobCmd} {
testsetplatform unix
list [catch {glob -nocomplain ~\\xyqrszzz/bar} msg] $msg
@@ -1121,6 +1121,112 @@ test filename-11.16 {Tcl_GlobCmd} {
list [catch {glob globTest} msg] $msg
} {0 globTest}
+set globname "globTest"
+set horribleglobname "glob\[\{Test"
+
+test filename-11.17 {Tcl_GlobCmd} {
+ list [catch {lsort [glob -directory $globname *]} msg] $msg
+} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
+ [file join $globname a3]\
+ [file join $globname "weird name.c"]\
+ [file join $globname x,z1.c]\
+ [file join $globname x1.c]\
+ [file join $globname y1.c] [file join $globname z1.c]]]]
+test filename-11.18 {Tcl_GlobCmd} {
+ list [catch {lsort [glob -path $globname/ *]} msg] $msg
+} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
+ [file join $globname a3]\
+ [file join $globname "weird name.c"]\
+ [file join $globname x,z1.c]\
+ [file join $globname x1.c]\
+ [file join $globname y1.c] [file join $globname z1.c]]]]
+test filename-11.19 {Tcl_GlobCmd} {
+ list [catch {lsort [glob -join -path \
+ [string range $globname 0 5] * *]} msg] $msg
+} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
+ [file join $globname a3]\
+ [file join $globname "weird name.c"]\
+ [file join $globname x,z1.c]\
+ [file join $globname x1.c]\
+ [file join $globname y1.c] [file join $globname z1.c]]]]
+test filename-11.20 {Tcl_GlobCmd} {
+ list [catch {lsort [glob -type d -dir $globname *]} msg] $msg
+} [list 0 [lsort [list [file join $globname a1]\
+ [file join $globname a2]\
+ [file join $globname a3]]]]
+test filename-11.21 {Tcl_GlobCmd} {
+ list [catch {lsort [glob -type d -path $globname *]} msg] $msg
+} [list 0 [lsort [list $globname]]]
+
+file rename globTest $horribleglobname
+set globname $horribleglobname
+
+test filename-11.22 {Tcl_GlobCmd} {
+ list [catch {lsort [glob -dir $globname *]} msg] $msg
+} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
+ [file join $globname a3]\
+ [file join $globname "weird name.c"]\
+ [file join $globname x,z1.c]\
+ [file join $globname x1.c]\
+ [file join $globname y1.c] [file join $globname z1.c]]]]
+test filename-11.23 {Tcl_GlobCmd} {
+ list [catch {lsort [glob -path $globname/ *]} msg] $msg
+} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
+ [file join $globname a3]\
+ [file join $globname "weird name.c"]\
+ [file join $globname x,z1.c]\
+ [file join $globname x1.c]\
+ [file join $globname y1.c] [file join $globname z1.c]]]]
+test filename-11.24 {Tcl_GlobCmd} {
+ list [catch {lsort [glob -join -path \
+ [string range $globname 0 5] * *]} msg] $msg
+} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
+ [file join $globname a3]\
+ [file join $globname "weird name.c"]\
+ [file join $globname x,z1.c]\
+ [file join $globname x1.c]\
+ [file join $globname y1.c] [file join $globname z1.c]]]]
+test filename-11.25 {Tcl_GlobCmd} {
+ list [catch {lsort [glob -type d -dir $globname *]} msg] $msg
+} [list 0 [lsort [list [file join $globname a1]\
+ [file join $globname a2]\
+ [file join $globname a3]]]]
+test filename-11.26 {Tcl_GlobCmd} {
+ list [catch {glob -type d -path $globname *} msg] $msg
+} [list 0 [list $globname]]
+test filename-11.27 {Tcl_GlobCmd} {
+ list [catch {glob -types abcde *} msg] $msg
+} {1 {bad argument to "-types": abcde}}
+test filename-11.28 {Tcl_GlobCmd} {
+ list [catch {glob -types z *} msg] $msg
+} {1 {bad argument to "-types": z}}
+test filename-11.29 {Tcl_GlobCmd} {
+ list [catch {glob -types {abcd efgh} *} msg] $msg
+} {1 {only one MacOS type or creator argument to "-types" allowed}}
+test filename-11.30 {Tcl_GlobCmd} {
+ list [catch {glob -types {{macintosh type TEXT} \
+ {macintosh creator ALFA} efgh} *} msg] $msg
+} {1 {only one MacOS type or creator argument to "-types" allowed}}
+test filename-11.31 {Tcl_GlobCmd} {
+ list [catch {glob -types} msg] $msg
+} {1 {missing argument to "-types"}}
+test filename-11.32 {Tcl_GlobCmd} {
+ list [catch {glob -path hello -dir hello *} msg] $msg
+} {1 {"-directory" cannot be used with "-path"}}
+test filename-11.33 {Tcl_GlobCmd} {
+ list [catch {glob -path} msg] $msg
+} {1 {missing argument to "-path"}}
+test filename-11.34 {Tcl_GlobCmd} {
+ list [catch {glob -direct} msg] $msg
+} {1 {missing argument to "-directory"}}
+test filename-11.35 {Tcl_GlobCmd} {
+ list [catch {glob -paths *} msg] $msg
+} {1 {bad option "-paths": must be -directory, -join, -nocomplain, -path, -types, or --}}
+
+file rename $horribleglobname globTest
+set globname globTest
+unset horribleglobname
+
test filename-12.1 {simple globbing} {unixOrPc} {
list [catch {glob {}} msg] $msg
} {0 .}
@@ -1292,6 +1398,18 @@ test filename-14.23 {slash globbing} {unixOrPc} {
test filename-14.24 {slash globbing} {pcOnly} {
glob {\\}
} /
+test filename-14.25 {type specific globbing} {
+ list [catch {lsort [glob -dir globTest -types f *]} msg] $msg
+} [list 0 [lsort [list \
+ [file join $globname "weird name.c"]\
+ [file join $globname x,z1.c]\
+ [file join $globname x1.c]\
+ [file join $globname y1.c] [file join $globname z1.c]]]]
+test filename-14.26 {type specific globbing} {
+ list [catch {glob -nocomplain -dir globTest -types {readonly} *} msg] $msg
+} [list 0 {}]
+
+unset globname
# The following tests are only valid for Unix systems.
# On some systems, like AFS, "000" protection doesn't prevent
diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c
index 248079d..8feb007 100644
--- a/unix/tclUnixFile.c
+++ b/unix/tclUnixFile.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: tclUnixFile.c,v 1.6 1999/04/16 00:48:05 stanton Exp $
+ * RCS: @(#) $Id: tclUnixFile.c,v 1.7 1999/12/12 22:46:50 hobbs Exp $
*/
#include "tclInt.h"
@@ -176,7 +176,7 @@ TclpFindExecutable(argv0)
/*
*----------------------------------------------------------------------
*
- * TclpMatchFiles --
+ * TclpMatchFilesTypes --
*
* This routine is used by the globbing code to search a
* directory for all files which match a given pattern.
@@ -195,15 +195,18 @@ TclpFindExecutable(argv0)
*/
int
-TclpMatchFiles(interp, separators, dirPtr, pattern, tail)
- Tcl_Interp *interp; /* Interpreter to receive results. */
- char *separators; /* Path separators to pass to TclDoGlob. */
- Tcl_DString *dirPtr; /* Contains path to directory to search. */
- char *pattern; /* Pattern to match against. */
- char *tail; /* Pointer to end of pattern. Must not
- * refer to a static string. */
+TclpMatchFilesTypes(
+ Tcl_Interp *interp, /* Interpreter to receive results. */
+ char *separators, /* Directory separators to pass to TclDoGlob. */
+ Tcl_DString *dirPtr, /* Contains path to directory to search. */
+ char *pattern, /* Pattern to match against. */
+ char *tail, /* Pointer to end of pattern. Tail must
+ * point to a location in pattern and must
+ * not be static.*/
+ GlobTypeData *types) /* Object containing list of acceptable types.
+ * May be NULL. */
{
- char *native, *dirName, *patternEnd = tail;
+ char *native, *fname, *dirName, *patternEnd = tail;
char savedChar = 0; /* lint. */
DIR *d;
Tcl_DString ds;
@@ -211,6 +214,7 @@ TclpMatchFiles(interp, separators, dirPtr, pattern, tail)
int matchHidden;
int result = TCL_OK;
int baseLength = Tcl_DStringLength(dirPtr);
+ Tcl_Obj *resultPtr;
/*
* Make sure that the directory part of the name really is a
@@ -289,6 +293,7 @@ TclpMatchFiles(interp, separators, dirPtr, pattern, tail)
savedChar = *patternEnd;
*patternEnd = '\0';
+ resultPtr = Tcl_GetObjResult(interp);
while (1) {
char *utf;
struct dirent *entryPtr;
@@ -298,12 +303,19 @@ TclpMatchFiles(interp, separators, dirPtr, pattern, tail)
break;
}
- /*
- * Don't match names starting with "." unless the "." is
- * present in the pattern.
- */
-
- if (!matchHidden && (*entryPtr->d_name == '.')) {
+ if (types != NULL && (types->perm & TCL_GLOB_PERM_HIDDEN)) {
+ /*
+ * We explicitly asked for hidden files, so turn around
+ * and ignore any file which isn't hidden.
+ */
+ if (*entryPtr->d_name != '.') {
+ continue;
+ }
+ } else if (!matchHidden && (*entryPtr->d_name == '.')) {
+ /*
+ * Don't match names starting with "." unless the "." is
+ * present in the pattern.
+ */
continue;
}
@@ -318,12 +330,79 @@ TclpMatchFiles(interp, separators, dirPtr, pattern, tail)
if (Tcl_StringMatch(utf, pattern) != 0) {
Tcl_DStringSetLength(dirPtr, baseLength);
Tcl_DStringAppend(dirPtr, utf, -1);
+ fname = Tcl_DStringValue(dirPtr);
if (tail == NULL) {
- Tcl_AppendElement(interp, Tcl_DStringValue(dirPtr));
- } else if ((TclpStat(Tcl_DStringValue(dirPtr), &statBuf) == 0)
+ int typeOk = 1;
+ if (types != NULL) {
+ if (types->perm != 0) {
+ struct stat buf;
+
+ if (TclpStat(fname, &buf) != 0) {
+ panic("stat failed on known file\n");
+ }
+ /*
+ * readonly means that there are NO write permissions
+ * (even for user), but execute is OK for anybody
+ */
+ if (
+ ((types->perm & TCL_GLOB_PERM_RONLY) &&
+ (buf.st_mode & (S_IWOTH|S_IWGRP|S_IWUSR))) ||
+ ((types->perm & TCL_GLOB_PERM_R) &&
+ (TclpAccess(fname, R_OK) != 0)) ||
+ ((types->perm & TCL_GLOB_PERM_W) &&
+ (TclpAccess(fname, W_OK) != 0)) ||
+ ((types->perm & TCL_GLOB_PERM_X) &&
+ (TclpAccess(fname, X_OK) != 0))
+ ) {
+ typeOk = 0;
+ }
+ }
+ if (typeOk && (types->type != 0)) {
+ struct stat buf;
+ /*
+ * We must match at least one flag to be listed
+ */
+ typeOk = 0;
+ if (TclpLstat(fname, &buf) >= 0) {
+ /*
+ * In order bcdpfls as in 'find -t'
+ */
+ if (
+ ((types->type & TCL_GLOB_TYPE_BLOCK) &&
+ S_ISBLK(buf.st_mode)) ||
+ ((types->type & TCL_GLOB_TYPE_CHAR) &&
+ S_ISCHR(buf.st_mode)) ||
+ ((types->type & TCL_GLOB_TYPE_DIR) &&
+ S_ISDIR(buf.st_mode)) ||
+ ((types->type & TCL_GLOB_TYPE_PIPE) &&
+ S_ISFIFO(buf.st_mode)) ||
+ ((types->type & TCL_GLOB_TYPE_FILE) &&
+ S_ISREG(buf.st_mode))
+#ifdef S_ISLNK
+ || ((types->type & TCL_GLOB_TYPE_LINK) &&
+ S_ISLNK(buf.st_mode))
+#endif
+#ifdef S_ISSOCK
+ || ((types->type & TCL_GLOB_TYPE_SOCK) &&
+ S_ISSOCK(buf.st_mode))
+#endif
+ ) {
+ typeOk = 1;
+ }
+ } else {
+ /* Posix error occurred */
+ }
+ }
+ }
+ if (typeOk) {
+ Tcl_ListObjAppendElement(interp, resultPtr,
+ Tcl_NewStringObj(fname,
+ Tcl_DStringLength(dirPtr)));
+ }
+ } else if ((TclpStat(fname, &statBuf) == 0)
&& S_ISDIR(statBuf.st_mode)) {
Tcl_DStringAppend(dirPtr, "/", 1);
- result = TclDoGlob(interp, separators, dirPtr, tail);
+ result = TclDoGlob(interp, separators, dirPtr, tail, types);
if (result != TCL_OK) {
Tcl_DStringFree(&ds);
break;
@@ -338,6 +417,25 @@ TclpMatchFiles(interp, separators, dirPtr, pattern, tail)
return result;
}
+/*
+ * TclpMatchFiles --
+ *
+ * This function is now obsolete. Call the above function
+ * 'TclpMatchFilesTypes' instead.
+ */
+int
+TclpMatchFiles(
+ Tcl_Interp *interp, /* Interpreter to receive results. */
+ char *separators, /* Directory separators to pass to TclDoGlob. */
+ Tcl_DString *dirPtr, /* Contains path to directory to search. */
+ char *pattern, /* Pattern to match against. */
+ char *tail) /* Pointer to end of pattern. Tail must
+ * point to a location in pattern and must
+ * not be static.*/
+{
+ return TclpMatchFilesTypes(interp,separators,dirPtr,pattern,tail,NULL);
+}
+
/*
*---------------------------------------------------------------------------
*
diff --git a/win/tclWinFile.c b/win/tclWinFile.c
index 3a04a46..1a689ac 100644
--- a/win/tclWinFile.c
+++ b/win/tclWinFile.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclWinFile.c,v 1.6 1999/04/21 21:50:34 rjohnson Exp $
+ * RCS: @(#) $Id: tclWinFile.c,v 1.7 1999/12/12 22:46:51 hobbs Exp $
*/
#include "tclWinInt.h"
@@ -89,7 +89,7 @@ TclpFindExecutable(argv0)
/*
*----------------------------------------------------------------------
*
- * TclpMatchFiles --
+ * TclpMatchFilesTypes --
*
* This routine is used by the globbing code to search a
* directory for all files which match a given pattern.
@@ -107,14 +107,16 @@ TclpFindExecutable(argv0)
*---------------------------------------------------------------------- */
int
-TclpMatchFiles(interp, separators, dirPtr, pattern, tail)
- Tcl_Interp *interp; /* Interpreter to receive results. */
- char *separators; /* Directory separators to pass to TclDoGlob. */
- Tcl_DString *dirPtr; /* Contains path to directory to search. */
- char *pattern; /* Pattern to match against. */
- char *tail; /* Pointer to end of pattern. Tail must
- * point to a location in pattern. Must not
- * point to a static string. */
+TclpMatchFilesTypes(
+ Tcl_Interp *interp, /* Interpreter to receive results. */
+ char *separators, /* Directory separators to pass to TclDoGlob. */
+ Tcl_DString *dirPtr, /* Contains path to directory to search. */
+ char *pattern, /* Pattern to match against. */
+ char *tail, /* Pointer to end of pattern. Tail must
+ * point to a location in pattern and must
+ * not be static.*/
+ GlobTypeData *types) /* Object containing list of acceptable types.
+ * May be NULL. */
{
char drivePat[] = "?:\\";
const char *message;
@@ -128,6 +130,7 @@ TclpMatchFiles(interp, separators, dirPtr, pattern, tail)
BOOL found;
Tcl_DString ds;
TCHAR *nativeName;
+ Tcl_Obj *resultPtr;
/*
* Convert the path to normalized form since some interfaces only
@@ -270,10 +273,11 @@ TclpMatchFiles(interp, separators, dirPtr, pattern, tail)
* Now iterate over all of the files in the directory.
*/
+ resultPtr = Tcl_GetObjResult(interp);
for (found = 1; found != 0;
found = (*tclWinProcs->findNextFileProc)(handle, &data)) {
TCHAR *nativeMatchResult;
- char *name;
+ char *name, *fname;
if (tclWinProcs->useWide) {
nativeName = (TCHAR *) data.w.cFileName;
@@ -320,20 +324,76 @@ TclpMatchFiles(interp, separators, dirPtr, pattern, tail)
Tcl_DStringAppend(dirPtr, name, -1);
Tcl_DStringFree(&ds);
- if (tail == NULL) {
- Tcl_AppendElement(interp, Tcl_DStringValue(dirPtr));
- } else {
- nativeName = Tcl_WinUtfToTChar(Tcl_DStringValue(dirPtr),
- Tcl_DStringLength(dirPtr), &ds);
- attr = (*tclWinProcs->getFileAttributesProc)(nativeName);
- Tcl_DStringFree(&ds);
+ fname = Tcl_DStringValue(dirPtr);
+ nativeName = Tcl_WinUtfToTChar(fname, Tcl_DStringLength(dirPtr), &ds);
+ attr = (*tclWinProcs->getFileAttributesProc)(nativeName);
+ Tcl_DStringFree(&ds);
- if (attr & FILE_ATTRIBUTE_DIRECTORY) {
- Tcl_DStringAppend(dirPtr, "/", 1);
- result = TclDoGlob(interp, separators, dirPtr, tail);
- if (result != TCL_OK) {
- break;
+ if (tail == NULL) {
+ int typeOk = 1;
+ if (types != NULL) {
+ if (types->perm != 0) {
+ if (
+ ((types->perm & TCL_GLOB_PERM_RONLY) &&
+ !(attr & FILE_ATTRIBUTE_READONLY)) ||
+ ((types->perm & TCL_GLOB_PERM_HIDDEN) &&
+ !(attr & FILE_ATTRIBUTE_HIDDEN)) ||
+ ((types->perm & TCL_GLOB_PERM_R) &&
+ (TclpAccess(fname, R_OK) != 0)) ||
+ ((types->perm & TCL_GLOB_PERM_W) &&
+ (TclpAccess(fname, W_OK) != 0)) ||
+ ((types->perm & TCL_GLOB_PERM_X) &&
+ (TclpAccess(fname, X_OK) != 0))
+ ) {
+ typeOk = 0;
+ }
}
+ if (typeOk && types->type != 0) {
+ struct stat buf;
+ /*
+ * We must match at least one flag to be listed
+ */
+ typeOk = 0;
+ if (TclpLstat(fname, &buf) >= 0) {
+ /*
+ * In order bcdpfls as in 'find -t'
+ */
+ if (
+ ((types->type & TCL_GLOB_TYPE_BLOCK) &&
+ S_ISBLK(buf.st_mode)) ||
+ ((types->type & TCL_GLOB_TYPE_CHAR) &&
+ S_ISCHR(buf.st_mode)) ||
+ ((types->type & TCL_GLOB_TYPE_DIR) &&
+ S_ISDIR(buf.st_mode)) ||
+ ((types->type & TCL_GLOB_TYPE_PIPE) &&
+ S_ISFIFO(buf.st_mode)) ||
+ ((types->type & TCL_GLOB_TYPE_FILE) &&
+ S_ISREG(buf.st_mode))
+#ifdef S_ISLNK
+ || ((types->type & TCL_GLOB_TYPE_LINK) &&
+ S_ISLNK(buf.st_mode))
+#endif
+#ifdef S_ISSOCK
+ || ((types->type & TCL_GLOB_TYPE_SOCK) &&
+ S_ISSOCK(buf.st_mode))
+#endif
+ ) {
+ typeOk = 1;
+ }
+ } else {
+ /* Posix error occurred */
+ }
+ }
+ }
+ if (typeOk) {
+ Tcl_ListObjAppendElement(interp, resultPtr,
+ Tcl_NewStringObj(fname, Tcl_DStringLength(dirPtr)));
+ }
+ } else if (attr & FILE_ATTRIBUTE_DIRECTORY) {
+ Tcl_DStringAppend(dirPtr, "/", 1);
+ result = TclDoGlob(interp, separators, dirPtr, tail, types);
+ if (result != TCL_OK) {
+ break;
}
}
Tcl_DStringSetLength(dirPtr, dirLength);
@@ -354,6 +414,25 @@ TclpMatchFiles(interp, separators, dirPtr, pattern, tail)
return TCL_ERROR;
}
+/*
+ * TclpMatchFiles --
+ *
+ * This function is now obsolete. Call the above function
+ * 'TclpMatchFilesTypes' instead.
+ */
+int
+TclpMatchFiles(
+ Tcl_Interp *interp, /* Interpreter to receive results. */
+ char *separators, /* Directory separators to pass to TclDoGlob. */
+ Tcl_DString *dirPtr, /* Contains path to directory to search. */
+ char *pattern, /* Pattern to match against. */
+ char *tail) /* Pointer to end of pattern. Tail must
+ * point to a location in pattern and must
+ * not be static.*/
+{
+ return TclpMatchFilesTypes(interp,separators,dirPtr,pattern,tail,NULL);
+}
+
/*
*----------------------------------------------------------------------
*
generated by cgit v0.12 at 2024-07-15 13:06:04 (GMT)