[25] | 1 | /* |
---|
| 2 | * tclCmdAH.c -- |
---|
| 3 | * |
---|
| 4 | * This file contains the top-level command routines for most of the Tcl |
---|
| 5 | * built-in commands whose names begin with the letters A to H. |
---|
| 6 | * |
---|
| 7 | * Copyright (c) 1987-1993 The Regents of the University of California. |
---|
| 8 | * Copyright (c) 1994-1997 Sun Microsystems, Inc. |
---|
| 9 | * |
---|
| 10 | * See the file "license.terms" for information on usage and redistribution of |
---|
| 11 | * this file, and for a DISCLAIMER OF ALL WARRANTIES. |
---|
| 12 | * |
---|
| 13 | * RCS: @(#) $Id: tclCmdAH.c,v 1.93 2008/03/14 16:07:23 dgp Exp $ |
---|
| 14 | */ |
---|
| 15 | |
---|
| 16 | #include "tclInt.h" |
---|
| 17 | #include <locale.h> |
---|
| 18 | |
---|
| 19 | /* |
---|
| 20 | * Prototypes for local procedures defined in this file: |
---|
| 21 | */ |
---|
| 22 | |
---|
| 23 | static int CheckAccess(Tcl_Interp *interp, Tcl_Obj *pathPtr, |
---|
| 24 | int mode); |
---|
| 25 | static int EncodingDirsObjCmd(ClientData dummy, |
---|
| 26 | Tcl_Interp *interp, int objc, |
---|
| 27 | Tcl_Obj *CONST objv[]); |
---|
| 28 | static int GetStatBuf(Tcl_Interp *interp, Tcl_Obj *pathPtr, |
---|
| 29 | Tcl_FSStatProc *statProc, Tcl_StatBuf *statPtr); |
---|
| 30 | static char * GetTypeFromMode(int mode); |
---|
| 31 | static int StoreStatData(Tcl_Interp *interp, Tcl_Obj *varName, |
---|
| 32 | Tcl_StatBuf *statPtr); |
---|
| 33 | |
---|
| 34 | /* |
---|
| 35 | *---------------------------------------------------------------------- |
---|
| 36 | * |
---|
| 37 | * Tcl_BreakObjCmd -- |
---|
| 38 | * |
---|
| 39 | * This procedure is invoked to process the "break" Tcl command. See the |
---|
| 40 | * user documentation for details on what it does. |
---|
| 41 | * |
---|
| 42 | * With the bytecode compiler, this procedure is only called when a |
---|
| 43 | * command name is computed at runtime, and is "break" or the name to |
---|
| 44 | * which "break" was renamed: e.g., "set z break; $z" |
---|
| 45 | * |
---|
| 46 | * Results: |
---|
| 47 | * A standard Tcl result. |
---|
| 48 | * |
---|
| 49 | * Side effects: |
---|
| 50 | * See the user documentation. |
---|
| 51 | * |
---|
| 52 | *---------------------------------------------------------------------- |
---|
| 53 | */ |
---|
| 54 | |
---|
| 55 | /* ARGSUSED */ |
---|
| 56 | int |
---|
| 57 | Tcl_BreakObjCmd( |
---|
| 58 | ClientData dummy, /* Not used. */ |
---|
| 59 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 60 | int objc, /* Number of arguments. */ |
---|
| 61 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
| 62 | { |
---|
| 63 | if (objc != 1) { |
---|
| 64 | Tcl_WrongNumArgs(interp, 1, objv, NULL); |
---|
| 65 | return TCL_ERROR; |
---|
| 66 | } |
---|
| 67 | return TCL_BREAK; |
---|
| 68 | } |
---|
| 69 | |
---|
| 70 | /* |
---|
| 71 | *---------------------------------------------------------------------- |
---|
| 72 | * |
---|
| 73 | * Tcl_CaseObjCmd -- |
---|
| 74 | * |
---|
| 75 | * This procedure is invoked to process the "case" Tcl command. See the |
---|
| 76 | * user documentation for details on what it does. THIS COMMAND IS |
---|
| 77 | * OBSOLETE AND DEPRECATED. SLATED FOR REMOVAL IN TCL 9.0. |
---|
| 78 | * |
---|
| 79 | * Results: |
---|
| 80 | * A standard Tcl object result. |
---|
| 81 | * |
---|
| 82 | * Side effects: |
---|
| 83 | * See the user documentation. |
---|
| 84 | * |
---|
| 85 | *---------------------------------------------------------------------- |
---|
| 86 | */ |
---|
| 87 | |
---|
| 88 | /* ARGSUSED */ |
---|
| 89 | int |
---|
| 90 | Tcl_CaseObjCmd( |
---|
| 91 | ClientData dummy, /* Not used. */ |
---|
| 92 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 93 | int objc, /* Number of arguments. */ |
---|
| 94 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
| 95 | { |
---|
| 96 | register int i; |
---|
| 97 | int body, result, caseObjc; |
---|
| 98 | char *stringPtr, *arg; |
---|
| 99 | Tcl_Obj *CONST *caseObjv; |
---|
| 100 | Tcl_Obj *armPtr; |
---|
| 101 | |
---|
| 102 | if (objc < 3) { |
---|
| 103 | Tcl_WrongNumArgs(interp, 1, objv, |
---|
| 104 | "string ?in? patList body ... ?default body?"); |
---|
| 105 | return TCL_ERROR; |
---|
| 106 | } |
---|
| 107 | |
---|
| 108 | stringPtr = TclGetString(objv[1]); |
---|
| 109 | body = -1; |
---|
| 110 | |
---|
| 111 | arg = TclGetString(objv[2]); |
---|
| 112 | if (strcmp(arg, "in") == 0) { |
---|
| 113 | i = 3; |
---|
| 114 | } else { |
---|
| 115 | i = 2; |
---|
| 116 | } |
---|
| 117 | caseObjc = objc - i; |
---|
| 118 | caseObjv = objv + i; |
---|
| 119 | |
---|
| 120 | /* |
---|
| 121 | * If all of the pattern/command pairs are lumped into a single argument, |
---|
| 122 | * split them out again. |
---|
| 123 | */ |
---|
| 124 | |
---|
| 125 | if (caseObjc == 1) { |
---|
| 126 | Tcl_Obj **newObjv; |
---|
| 127 | |
---|
| 128 | TclListObjGetElements(interp, caseObjv[0], &caseObjc, &newObjv); |
---|
| 129 | caseObjv = newObjv; |
---|
| 130 | } |
---|
| 131 | |
---|
| 132 | for (i = 0; i < caseObjc; i += 2) { |
---|
| 133 | int patObjc, j; |
---|
| 134 | CONST char **patObjv; |
---|
| 135 | char *pat; |
---|
| 136 | unsigned char *p; |
---|
| 137 | |
---|
| 138 | if (i == (caseObjc - 1)) { |
---|
| 139 | Tcl_ResetResult(interp); |
---|
| 140 | Tcl_AppendResult(interp, "extra case pattern with no body", NULL); |
---|
| 141 | return TCL_ERROR; |
---|
| 142 | } |
---|
| 143 | |
---|
| 144 | /* |
---|
| 145 | * Check for special case of single pattern (no list) with no |
---|
| 146 | * backslash sequences. |
---|
| 147 | */ |
---|
| 148 | |
---|
| 149 | pat = TclGetString(caseObjv[i]); |
---|
| 150 | for (p = (unsigned char *) pat; *p != '\0'; p++) { |
---|
| 151 | if (isspace(*p) || (*p == '\\')) { /* INTL: ISO space, UCHAR */ |
---|
| 152 | break; |
---|
| 153 | } |
---|
| 154 | } |
---|
| 155 | if (*p == '\0') { |
---|
| 156 | if ((*pat == 'd') && (strcmp(pat, "default") == 0)) { |
---|
| 157 | body = i + 1; |
---|
| 158 | } |
---|
| 159 | if (Tcl_StringMatch(stringPtr, pat)) { |
---|
| 160 | body = i + 1; |
---|
| 161 | goto match; |
---|
| 162 | } |
---|
| 163 | continue; |
---|
| 164 | } |
---|
| 165 | |
---|
| 166 | /* |
---|
| 167 | * Break up pattern lists, then check each of the patterns in the |
---|
| 168 | * list. |
---|
| 169 | */ |
---|
| 170 | |
---|
| 171 | result = Tcl_SplitList(interp, pat, &patObjc, &patObjv); |
---|
| 172 | if (result != TCL_OK) { |
---|
| 173 | return result; |
---|
| 174 | } |
---|
| 175 | for (j = 0; j < patObjc; j++) { |
---|
| 176 | if (Tcl_StringMatch(stringPtr, patObjv[j])) { |
---|
| 177 | body = i + 1; |
---|
| 178 | break; |
---|
| 179 | } |
---|
| 180 | } |
---|
| 181 | ckfree((char *) patObjv); |
---|
| 182 | if (j < patObjc) { |
---|
| 183 | break; |
---|
| 184 | } |
---|
| 185 | } |
---|
| 186 | |
---|
| 187 | match: |
---|
| 188 | if (body != -1) { |
---|
| 189 | armPtr = caseObjv[body - 1]; |
---|
| 190 | result = Tcl_EvalObjEx(interp, caseObjv[body], 0); |
---|
| 191 | if (result == TCL_ERROR) { |
---|
| 192 | Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( |
---|
| 193 | "\n (\"%.50s\" arm line %d)", |
---|
| 194 | TclGetString(armPtr), interp->errorLine)); |
---|
| 195 | } |
---|
| 196 | return result; |
---|
| 197 | } |
---|
| 198 | |
---|
| 199 | /* |
---|
| 200 | * Nothing matched: return nothing. |
---|
| 201 | */ |
---|
| 202 | |
---|
| 203 | return TCL_OK; |
---|
| 204 | } |
---|
| 205 | |
---|
| 206 | /* |
---|
| 207 | *---------------------------------------------------------------------- |
---|
| 208 | * |
---|
| 209 | * Tcl_CatchObjCmd -- |
---|
| 210 | * |
---|
| 211 | * This object-based procedure is invoked to process the "catch" Tcl |
---|
| 212 | * command. See the user documentation for details on what it does. |
---|
| 213 | * |
---|
| 214 | * Results: |
---|
| 215 | * A standard Tcl object result. |
---|
| 216 | * |
---|
| 217 | * Side effects: |
---|
| 218 | * See the user documentation. |
---|
| 219 | * |
---|
| 220 | *---------------------------------------------------------------------- |
---|
| 221 | */ |
---|
| 222 | |
---|
| 223 | /* ARGSUSED */ |
---|
| 224 | int |
---|
| 225 | Tcl_CatchObjCmd( |
---|
| 226 | ClientData dummy, /* Not used. */ |
---|
| 227 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 228 | int objc, /* Number of arguments. */ |
---|
| 229 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
| 230 | { |
---|
| 231 | Tcl_Obj *varNamePtr = NULL; |
---|
| 232 | Tcl_Obj *optionVarNamePtr = NULL; |
---|
| 233 | int result; |
---|
| 234 | Interp *iPtr = (Interp *) interp; |
---|
| 235 | |
---|
| 236 | if ((objc < 2) || (objc > 4)) { |
---|
| 237 | Tcl_WrongNumArgs(interp, 1, objv, |
---|
| 238 | "script ?resultVarName? ?optionVarName?"); |
---|
| 239 | return TCL_ERROR; |
---|
| 240 | } |
---|
| 241 | |
---|
| 242 | if (objc >= 3) { |
---|
| 243 | varNamePtr = objv[2]; |
---|
| 244 | } |
---|
| 245 | if (objc == 4) { |
---|
| 246 | optionVarNamePtr = objv[3]; |
---|
| 247 | } |
---|
| 248 | |
---|
| 249 | /* |
---|
| 250 | * TIP #280. Make invoking context available to caught script. |
---|
| 251 | */ |
---|
| 252 | |
---|
| 253 | result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1); |
---|
| 254 | |
---|
| 255 | /* |
---|
| 256 | * We disable catch in interpreters where the limit has been exceeded. |
---|
| 257 | */ |
---|
| 258 | |
---|
| 259 | if (Tcl_LimitExceeded(interp)) { |
---|
| 260 | Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( |
---|
| 261 | "\n (\"catch\" body line %d)", interp->errorLine)); |
---|
| 262 | return TCL_ERROR; |
---|
| 263 | } |
---|
| 264 | |
---|
| 265 | if (objc >= 3) { |
---|
| 266 | if (NULL == Tcl_ObjSetVar2(interp, varNamePtr, NULL, |
---|
| 267 | Tcl_GetObjResult(interp), 0)) { |
---|
| 268 | Tcl_ResetResult(interp); |
---|
| 269 | Tcl_AppendResult(interp, |
---|
| 270 | "couldn't save command result in variable", NULL); |
---|
| 271 | return TCL_ERROR; |
---|
| 272 | } |
---|
| 273 | } |
---|
| 274 | if (objc == 4) { |
---|
| 275 | Tcl_Obj *options = Tcl_GetReturnOptions(interp, result); |
---|
| 276 | if (NULL == Tcl_ObjSetVar2(interp, optionVarNamePtr, NULL, |
---|
| 277 | options, 0)) { |
---|
| 278 | Tcl_ResetResult(interp); |
---|
| 279 | Tcl_AppendResult(interp, |
---|
| 280 | "couldn't save return options in variable", NULL); |
---|
| 281 | return TCL_ERROR; |
---|
| 282 | } |
---|
| 283 | } |
---|
| 284 | |
---|
| 285 | Tcl_ResetResult(interp); |
---|
| 286 | Tcl_SetObjResult(interp, Tcl_NewIntObj(result)); |
---|
| 287 | return TCL_OK; |
---|
| 288 | } |
---|
| 289 | |
---|
| 290 | /* |
---|
| 291 | *---------------------------------------------------------------------- |
---|
| 292 | * |
---|
| 293 | * Tcl_CdObjCmd -- |
---|
| 294 | * |
---|
| 295 | * This procedure is invoked to process the "cd" Tcl command. See the |
---|
| 296 | * user documentation for details on what it does. |
---|
| 297 | * |
---|
| 298 | * Results: |
---|
| 299 | * A standard Tcl result. |
---|
| 300 | * |
---|
| 301 | * Side effects: |
---|
| 302 | * See the user documentation. |
---|
| 303 | * |
---|
| 304 | *---------------------------------------------------------------------- |
---|
| 305 | */ |
---|
| 306 | |
---|
| 307 | /* ARGSUSED */ |
---|
| 308 | int |
---|
| 309 | Tcl_CdObjCmd( |
---|
| 310 | ClientData dummy, /* Not used. */ |
---|
| 311 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 312 | int objc, /* Number of arguments. */ |
---|
| 313 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
| 314 | { |
---|
| 315 | Tcl_Obj *dir; |
---|
| 316 | int result; |
---|
| 317 | |
---|
| 318 | if (objc > 2) { |
---|
| 319 | Tcl_WrongNumArgs(interp, 1, objv, "?dirName?"); |
---|
| 320 | return TCL_ERROR; |
---|
| 321 | } |
---|
| 322 | |
---|
| 323 | if (objc == 2) { |
---|
| 324 | dir = objv[1]; |
---|
| 325 | } else { |
---|
| 326 | TclNewLiteralStringObj(dir, "~"); |
---|
| 327 | Tcl_IncrRefCount(dir); |
---|
| 328 | } |
---|
| 329 | if (Tcl_FSConvertToPathType(interp, dir) != TCL_OK) { |
---|
| 330 | result = TCL_ERROR; |
---|
| 331 | } else { |
---|
| 332 | result = Tcl_FSChdir(dir); |
---|
| 333 | if (result != TCL_OK) { |
---|
| 334 | Tcl_AppendResult(interp, "couldn't change working directory to \"", |
---|
| 335 | TclGetString(dir), "\": ", Tcl_PosixError(interp), NULL); |
---|
| 336 | result = TCL_ERROR; |
---|
| 337 | } |
---|
| 338 | } |
---|
| 339 | if (objc != 2) { |
---|
| 340 | Tcl_DecrRefCount(dir); |
---|
| 341 | } |
---|
| 342 | return result; |
---|
| 343 | } |
---|
| 344 | |
---|
| 345 | /* |
---|
| 346 | *---------------------------------------------------------------------- |
---|
| 347 | * |
---|
| 348 | * Tcl_ConcatObjCmd -- |
---|
| 349 | * |
---|
| 350 | * This object-based procedure is invoked to process the "concat" Tcl |
---|
| 351 | * command. See the user documentation for details on what it does. |
---|
| 352 | * |
---|
| 353 | * Results: |
---|
| 354 | * A standard Tcl object result. |
---|
| 355 | * |
---|
| 356 | * Side effects: |
---|
| 357 | * See the user documentation. |
---|
| 358 | * |
---|
| 359 | *---------------------------------------------------------------------- |
---|
| 360 | */ |
---|
| 361 | |
---|
| 362 | /* ARGSUSED */ |
---|
| 363 | int |
---|
| 364 | Tcl_ConcatObjCmd( |
---|
| 365 | ClientData dummy, /* Not used. */ |
---|
| 366 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 367 | int objc, /* Number of arguments. */ |
---|
| 368 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
| 369 | { |
---|
| 370 | if (objc >= 2) { |
---|
| 371 | Tcl_SetObjResult(interp, Tcl_ConcatObj(objc-1, objv+1)); |
---|
| 372 | } |
---|
| 373 | return TCL_OK; |
---|
| 374 | } |
---|
| 375 | |
---|
| 376 | /* |
---|
| 377 | *---------------------------------------------------------------------- |
---|
| 378 | * |
---|
| 379 | * Tcl_ContinueObjCmd -- |
---|
| 380 | * |
---|
| 381 | * This procedure is invoked to process the "continue" Tcl command. See |
---|
| 382 | * the user documentation for details on what it does. |
---|
| 383 | * |
---|
| 384 | * With the bytecode compiler, this procedure is only called when a |
---|
| 385 | * command name is computed at runtime, and is "continue" or the name to |
---|
| 386 | * which "continue" was renamed: e.g., "set z continue; $z" |
---|
| 387 | * |
---|
| 388 | * Results: |
---|
| 389 | * A standard Tcl result. |
---|
| 390 | * |
---|
| 391 | * Side effects: |
---|
| 392 | * See the user documentation. |
---|
| 393 | * |
---|
| 394 | *---------------------------------------------------------------------- |
---|
| 395 | */ |
---|
| 396 | |
---|
| 397 | /* ARGSUSED */ |
---|
| 398 | int |
---|
| 399 | Tcl_ContinueObjCmd( |
---|
| 400 | ClientData dummy, /* Not used. */ |
---|
| 401 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 402 | int objc, /* Number of arguments. */ |
---|
| 403 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
| 404 | { |
---|
| 405 | if (objc != 1) { |
---|
| 406 | Tcl_WrongNumArgs(interp, 1, objv, NULL); |
---|
| 407 | return TCL_ERROR; |
---|
| 408 | } |
---|
| 409 | return TCL_CONTINUE; |
---|
| 410 | } |
---|
| 411 | |
---|
| 412 | /* |
---|
| 413 | *---------------------------------------------------------------------- |
---|
| 414 | * |
---|
| 415 | * Tcl_EncodingObjCmd -- |
---|
| 416 | * |
---|
| 417 | * This command manipulates encodings. |
---|
| 418 | * |
---|
| 419 | * Results: |
---|
| 420 | * A standard Tcl result. |
---|
| 421 | * |
---|
| 422 | * Side effects: |
---|
| 423 | * See the user documentation. |
---|
| 424 | * |
---|
| 425 | *---------------------------------------------------------------------- |
---|
| 426 | */ |
---|
| 427 | |
---|
| 428 | int |
---|
| 429 | Tcl_EncodingObjCmd( |
---|
| 430 | ClientData dummy, /* Not used. */ |
---|
| 431 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 432 | int objc, /* Number of arguments. */ |
---|
| 433 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
| 434 | { |
---|
| 435 | int index; |
---|
| 436 | |
---|
| 437 | static CONST char *optionStrings[] = { |
---|
| 438 | "convertfrom", "convertto", "dirs", "names", "system", |
---|
| 439 | NULL |
---|
| 440 | }; |
---|
| 441 | enum options { |
---|
| 442 | ENC_CONVERTFROM, ENC_CONVERTTO, ENC_DIRS, ENC_NAMES, ENC_SYSTEM |
---|
| 443 | }; |
---|
| 444 | |
---|
| 445 | if (objc < 2) { |
---|
| 446 | Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); |
---|
| 447 | return TCL_ERROR; |
---|
| 448 | } |
---|
| 449 | if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, |
---|
| 450 | &index) != TCL_OK) { |
---|
| 451 | return TCL_ERROR; |
---|
| 452 | } |
---|
| 453 | |
---|
| 454 | switch ((enum options) index) { |
---|
| 455 | case ENC_CONVERTTO: |
---|
| 456 | case ENC_CONVERTFROM: { |
---|
| 457 | Tcl_Obj *data; |
---|
| 458 | Tcl_DString ds; |
---|
| 459 | Tcl_Encoding encoding; |
---|
| 460 | int length; |
---|
| 461 | char *stringPtr; |
---|
| 462 | |
---|
| 463 | if (objc == 3) { |
---|
| 464 | encoding = Tcl_GetEncoding(interp, NULL); |
---|
| 465 | data = objv[2]; |
---|
| 466 | } else if (objc == 4) { |
---|
| 467 | if (Tcl_GetEncodingFromObj(interp, objv[2], &encoding) != TCL_OK) { |
---|
| 468 | return TCL_ERROR; |
---|
| 469 | } |
---|
| 470 | data = objv[3]; |
---|
| 471 | } else { |
---|
| 472 | Tcl_WrongNumArgs(interp, 2, objv, "?encoding? data"); |
---|
| 473 | return TCL_ERROR; |
---|
| 474 | } |
---|
| 475 | |
---|
| 476 | if ((enum options) index == ENC_CONVERTFROM) { |
---|
| 477 | /* |
---|
| 478 | * Treat the string as binary data. |
---|
| 479 | */ |
---|
| 480 | |
---|
| 481 | stringPtr = (char *) Tcl_GetByteArrayFromObj(data, &length); |
---|
| 482 | Tcl_ExternalToUtfDString(encoding, stringPtr, length, &ds); |
---|
| 483 | |
---|
| 484 | /* |
---|
| 485 | * Note that we cannot use Tcl_DStringResult here because it will |
---|
| 486 | * truncate the string at the first null byte. |
---|
| 487 | */ |
---|
| 488 | |
---|
| 489 | Tcl_SetObjResult(interp, Tcl_NewStringObj( |
---|
| 490 | Tcl_DStringValue(&ds), Tcl_DStringLength(&ds))); |
---|
| 491 | Tcl_DStringFree(&ds); |
---|
| 492 | } else { |
---|
| 493 | /* |
---|
| 494 | * Store the result as binary data. |
---|
| 495 | */ |
---|
| 496 | |
---|
| 497 | stringPtr = TclGetStringFromObj(data, &length); |
---|
| 498 | Tcl_UtfToExternalDString(encoding, stringPtr, length, &ds); |
---|
| 499 | Tcl_SetObjResult(interp, Tcl_NewByteArrayObj( |
---|
| 500 | (unsigned char *) Tcl_DStringValue(&ds), |
---|
| 501 | Tcl_DStringLength(&ds))); |
---|
| 502 | Tcl_DStringFree(&ds); |
---|
| 503 | } |
---|
| 504 | |
---|
| 505 | Tcl_FreeEncoding(encoding); |
---|
| 506 | break; |
---|
| 507 | } |
---|
| 508 | case ENC_DIRS: |
---|
| 509 | return EncodingDirsObjCmd(dummy, interp, objc-1, objv+1); |
---|
| 510 | case ENC_NAMES: |
---|
| 511 | if (objc > 2) { |
---|
| 512 | Tcl_WrongNumArgs(interp, 2, objv, NULL); |
---|
| 513 | return TCL_ERROR; |
---|
| 514 | } |
---|
| 515 | Tcl_GetEncodingNames(interp); |
---|
| 516 | break; |
---|
| 517 | case ENC_SYSTEM: |
---|
| 518 | if (objc > 3) { |
---|
| 519 | Tcl_WrongNumArgs(interp, 2, objv, "?encoding?"); |
---|
| 520 | return TCL_ERROR; |
---|
| 521 | } |
---|
| 522 | if (objc == 2) { |
---|
| 523 | Tcl_SetObjResult(interp, Tcl_NewStringObj( |
---|
| 524 | Tcl_GetEncodingName(NULL), -1)); |
---|
| 525 | } else { |
---|
| 526 | return Tcl_SetSystemEncoding(interp, TclGetString(objv[2])); |
---|
| 527 | } |
---|
| 528 | break; |
---|
| 529 | } |
---|
| 530 | return TCL_OK; |
---|
| 531 | } |
---|
| 532 | |
---|
| 533 | /* |
---|
| 534 | *---------------------------------------------------------------------- |
---|
| 535 | * |
---|
| 536 | * EncodingDirsObjCmd -- |
---|
| 537 | * |
---|
| 538 | * This command manipulates the encoding search path. |
---|
| 539 | * |
---|
| 540 | * Results: |
---|
| 541 | * A standard Tcl result. |
---|
| 542 | * |
---|
| 543 | * Side effects: |
---|
| 544 | * Can set the encoding search path. |
---|
| 545 | * |
---|
| 546 | *---------------------------------------------------------------------- |
---|
| 547 | */ |
---|
| 548 | |
---|
| 549 | int |
---|
| 550 | EncodingDirsObjCmd( |
---|
| 551 | ClientData dummy, /* Not used. */ |
---|
| 552 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 553 | int objc, /* Number of arguments. */ |
---|
| 554 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
| 555 | { |
---|
| 556 | if (objc > 2) { |
---|
| 557 | Tcl_WrongNumArgs(interp, 1, objv, "?dirList?"); |
---|
| 558 | return TCL_ERROR; |
---|
| 559 | } |
---|
| 560 | if (objc == 1) { |
---|
| 561 | Tcl_SetObjResult(interp, Tcl_GetEncodingSearchPath()); |
---|
| 562 | return TCL_OK; |
---|
| 563 | } |
---|
| 564 | if (Tcl_SetEncodingSearchPath(objv[1]) == TCL_ERROR) { |
---|
| 565 | Tcl_AppendResult(interp, "expected directory list but got \"", |
---|
| 566 | TclGetString(objv[1]), "\"", NULL); |
---|
| 567 | return TCL_ERROR; |
---|
| 568 | } |
---|
| 569 | Tcl_SetObjResult(interp, objv[1]); |
---|
| 570 | return TCL_OK; |
---|
| 571 | } |
---|
| 572 | |
---|
| 573 | /* |
---|
| 574 | *---------------------------------------------------------------------- |
---|
| 575 | * |
---|
| 576 | * Tcl_ErrorObjCmd -- |
---|
| 577 | * |
---|
| 578 | * This procedure is invoked to process the "error" Tcl command. See the |
---|
| 579 | * user documentation for details on what it does. |
---|
| 580 | * |
---|
| 581 | * Results: |
---|
| 582 | * A standard Tcl object result. |
---|
| 583 | * |
---|
| 584 | * Side effects: |
---|
| 585 | * See the user documentation. |
---|
| 586 | * |
---|
| 587 | *---------------------------------------------------------------------- |
---|
| 588 | */ |
---|
| 589 | |
---|
| 590 | /* ARGSUSED */ |
---|
| 591 | int |
---|
| 592 | Tcl_ErrorObjCmd( |
---|
| 593 | ClientData dummy, /* Not used. */ |
---|
| 594 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 595 | int objc, /* Number of arguments. */ |
---|
| 596 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
| 597 | { |
---|
| 598 | Tcl_Obj *options, *optName; |
---|
| 599 | |
---|
| 600 | if ((objc < 2) || (objc > 4)) { |
---|
| 601 | Tcl_WrongNumArgs(interp, 1, objv, "message ?errorInfo? ?errorCode?"); |
---|
| 602 | return TCL_ERROR; |
---|
| 603 | } |
---|
| 604 | |
---|
| 605 | TclNewLiteralStringObj(options, "-code error -level 0"); |
---|
| 606 | |
---|
| 607 | if (objc >= 3) { /* Process the optional info argument */ |
---|
| 608 | TclNewLiteralStringObj(optName, "-errorinfo"); |
---|
| 609 | Tcl_ListObjAppendElement(NULL, options, optName); |
---|
| 610 | Tcl_ListObjAppendElement(NULL, options, objv[2]); |
---|
| 611 | } |
---|
| 612 | |
---|
| 613 | if (objc >= 4) { /* Process the optional code argument */ |
---|
| 614 | TclNewLiteralStringObj(optName, "-errorcode"); |
---|
| 615 | Tcl_ListObjAppendElement(NULL, options, optName); |
---|
| 616 | Tcl_ListObjAppendElement(NULL, options, objv[3]); |
---|
| 617 | } |
---|
| 618 | |
---|
| 619 | Tcl_SetObjResult(interp, objv[1]); |
---|
| 620 | return Tcl_SetReturnOptions(interp, options); |
---|
| 621 | } |
---|
| 622 | |
---|
| 623 | /* |
---|
| 624 | *---------------------------------------------------------------------- |
---|
| 625 | * |
---|
| 626 | * Tcl_EvalObjCmd -- |
---|
| 627 | * |
---|
| 628 | * This object-based procedure is invoked to process the "eval" Tcl |
---|
| 629 | * command. See the user documentation for details on what it does. |
---|
| 630 | * |
---|
| 631 | * Results: |
---|
| 632 | * A standard Tcl object result. |
---|
| 633 | * |
---|
| 634 | * Side effects: |
---|
| 635 | * See the user documentation. |
---|
| 636 | * |
---|
| 637 | *---------------------------------------------------------------------- |
---|
| 638 | */ |
---|
| 639 | |
---|
| 640 | /* ARGSUSED */ |
---|
| 641 | int |
---|
| 642 | Tcl_EvalObjCmd( |
---|
| 643 | ClientData dummy, /* Not used. */ |
---|
| 644 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 645 | int objc, /* Number of arguments. */ |
---|
| 646 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
| 647 | { |
---|
| 648 | int result; |
---|
| 649 | register Tcl_Obj *objPtr; |
---|
| 650 | Interp *iPtr = (Interp *) interp; |
---|
| 651 | |
---|
| 652 | if (objc < 2) { |
---|
| 653 | Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?"); |
---|
| 654 | return TCL_ERROR; |
---|
| 655 | } |
---|
| 656 | |
---|
| 657 | if (objc == 2) { |
---|
| 658 | /* |
---|
| 659 | * TIP #280. Make invoking context available to eval'd script. |
---|
| 660 | */ |
---|
| 661 | |
---|
| 662 | result = TclEvalObjEx(interp, objv[1], TCL_EVAL_DIRECT, |
---|
| 663 | iPtr->cmdFramePtr, 1); |
---|
| 664 | } else { |
---|
| 665 | /* |
---|
| 666 | * More than one argument: concatenate them together with spaces |
---|
| 667 | * between, then evaluate the result. Tcl_EvalObjEx will delete the |
---|
| 668 | * object when it decrements its refcount after eval'ing it. |
---|
| 669 | */ |
---|
| 670 | |
---|
| 671 | objPtr = Tcl_ConcatObj(objc-1, objv+1); |
---|
| 672 | |
---|
| 673 | /* |
---|
| 674 | * TIP #280. Make invoking context available to eval'd script. |
---|
| 675 | */ |
---|
| 676 | |
---|
| 677 | result = TclEvalObjEx(interp, objPtr, TCL_EVAL_DIRECT, NULL, 0); |
---|
| 678 | } |
---|
| 679 | if (result == TCL_ERROR) { |
---|
| 680 | Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( |
---|
| 681 | "\n (\"eval\" body line %d)", interp->errorLine)); |
---|
| 682 | } |
---|
| 683 | return result; |
---|
| 684 | } |
---|
| 685 | |
---|
| 686 | /* |
---|
| 687 | *---------------------------------------------------------------------- |
---|
| 688 | * |
---|
| 689 | * Tcl_ExitObjCmd -- |
---|
| 690 | * |
---|
| 691 | * This procedure is invoked to process the "exit" Tcl command. See the |
---|
| 692 | * user documentation for details on what it does. |
---|
| 693 | * |
---|
| 694 | * Results: |
---|
| 695 | * A standard Tcl object result. |
---|
| 696 | * |
---|
| 697 | * Side effects: |
---|
| 698 | * See the user documentation. |
---|
| 699 | * |
---|
| 700 | *---------------------------------------------------------------------- |
---|
| 701 | */ |
---|
| 702 | |
---|
| 703 | /* ARGSUSED */ |
---|
| 704 | int |
---|
| 705 | Tcl_ExitObjCmd( |
---|
| 706 | ClientData dummy, /* Not used. */ |
---|
| 707 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 708 | int objc, /* Number of arguments. */ |
---|
| 709 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
| 710 | { |
---|
| 711 | int value; |
---|
| 712 | |
---|
| 713 | if ((objc != 1) && (objc != 2)) { |
---|
| 714 | Tcl_WrongNumArgs(interp, 1, objv, "?returnCode?"); |
---|
| 715 | return TCL_ERROR; |
---|
| 716 | } |
---|
| 717 | |
---|
| 718 | if (objc == 1) { |
---|
| 719 | value = 0; |
---|
| 720 | } else if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) { |
---|
| 721 | return TCL_ERROR; |
---|
| 722 | } |
---|
| 723 | Tcl_Exit(value); |
---|
| 724 | /*NOTREACHED*/ |
---|
| 725 | return TCL_OK; /* Better not ever reach this! */ |
---|
| 726 | } |
---|
| 727 | |
---|
| 728 | /* |
---|
| 729 | *---------------------------------------------------------------------- |
---|
| 730 | * |
---|
| 731 | * Tcl_ExprObjCmd -- |
---|
| 732 | * |
---|
| 733 | * This object-based procedure is invoked to process the "expr" Tcl |
---|
| 734 | * command. See the user documentation for details on what it does. |
---|
| 735 | * |
---|
| 736 | * With the bytecode compiler, this procedure is called in two |
---|
| 737 | * circumstances: 1) to execute expr commands that are too complicated or |
---|
| 738 | * too unsafe to try compiling directly into an inline sequence of |
---|
| 739 | * instructions, and 2) to execute commands where the command name is |
---|
| 740 | * computed at runtime and is "expr" or the name to which "expr" was |
---|
| 741 | * renamed (e.g., "set z expr; $z 2+3") |
---|
| 742 | * |
---|
| 743 | * Results: |
---|
| 744 | * A standard Tcl object result. |
---|
| 745 | * |
---|
| 746 | * Side effects: |
---|
| 747 | * See the user documentation. |
---|
| 748 | * |
---|
| 749 | *---------------------------------------------------------------------- |
---|
| 750 | */ |
---|
| 751 | |
---|
| 752 | /* ARGSUSED */ |
---|
| 753 | int |
---|
| 754 | Tcl_ExprObjCmd( |
---|
| 755 | ClientData dummy, /* Not used. */ |
---|
| 756 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 757 | int objc, /* Number of arguments. */ |
---|
| 758 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
| 759 | { |
---|
| 760 | Tcl_Obj *resultPtr; |
---|
| 761 | int result; |
---|
| 762 | |
---|
| 763 | if (objc < 2) { |
---|
| 764 | Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?"); |
---|
| 765 | return TCL_ERROR; |
---|
| 766 | } |
---|
| 767 | |
---|
| 768 | if (objc == 2) { |
---|
| 769 | result = Tcl_ExprObj(interp, objv[1], &resultPtr); |
---|
| 770 | } else { |
---|
| 771 | Tcl_Obj *objPtr = Tcl_ConcatObj(objc-1, objv+1); |
---|
| 772 | Tcl_IncrRefCount(objPtr); |
---|
| 773 | result = Tcl_ExprObj(interp, objPtr, &resultPtr); |
---|
| 774 | Tcl_DecrRefCount(objPtr); |
---|
| 775 | } |
---|
| 776 | |
---|
| 777 | if (result == TCL_OK) { |
---|
| 778 | Tcl_SetObjResult(interp, resultPtr); |
---|
| 779 | Tcl_DecrRefCount(resultPtr); /* Done with the result object */ |
---|
| 780 | } |
---|
| 781 | |
---|
| 782 | return result; |
---|
| 783 | } |
---|
| 784 | |
---|
| 785 | /* |
---|
| 786 | *---------------------------------------------------------------------- |
---|
| 787 | * |
---|
| 788 | * Tcl_FileObjCmd -- |
---|
| 789 | * |
---|
| 790 | * This procedure is invoked to process the "file" Tcl command. See the |
---|
| 791 | * user documentation for details on what it does. PLEASE NOTE THAT THIS |
---|
| 792 | * FAILS WITH FILENAMES AND PATHS WITH EMBEDDED NULLS. With the |
---|
| 793 | * object-based Tcl_FS APIs, the above NOTE may no longer be true. In any |
---|
| 794 | * case this assertion should be tested. |
---|
| 795 | * |
---|
| 796 | * Results: |
---|
| 797 | * A standard Tcl result. |
---|
| 798 | * |
---|
| 799 | * Side effects: |
---|
| 800 | * See the user documentation. |
---|
| 801 | * |
---|
| 802 | *---------------------------------------------------------------------- |
---|
| 803 | */ |
---|
| 804 | |
---|
| 805 | /* ARGSUSED */ |
---|
| 806 | int |
---|
| 807 | Tcl_FileObjCmd( |
---|
| 808 | ClientData dummy, /* Not used. */ |
---|
| 809 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 810 | int objc, /* Number of arguments. */ |
---|
| 811 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
| 812 | { |
---|
| 813 | int index, value; |
---|
| 814 | Tcl_StatBuf buf; |
---|
| 815 | struct utimbuf tval; |
---|
| 816 | |
---|
| 817 | /* |
---|
| 818 | * This list of constants should match the fileOption string array below. |
---|
| 819 | */ |
---|
| 820 | |
---|
| 821 | static CONST char *fileOptions[] = { |
---|
| 822 | "atime", "attributes", "channels", "copy", |
---|
| 823 | "delete", |
---|
| 824 | "dirname", "executable", "exists", "extension", |
---|
| 825 | "isdirectory", "isfile", "join", "link", |
---|
| 826 | "lstat", "mtime", "mkdir", "nativename", |
---|
| 827 | "normalize", "owned", |
---|
| 828 | "pathtype", "readable", "readlink", "rename", |
---|
| 829 | "rootname", "separator", "size", "split", |
---|
| 830 | "stat", "system", |
---|
| 831 | "tail", "type", "volumes", "writable", |
---|
| 832 | NULL |
---|
| 833 | }; |
---|
| 834 | enum options { |
---|
| 835 | FCMD_ATIME, FCMD_ATTRIBUTES, FCMD_CHANNELS, FCMD_COPY, |
---|
| 836 | FCMD_DELETE, |
---|
| 837 | FCMD_DIRNAME, FCMD_EXECUTABLE, FCMD_EXISTS, FCMD_EXTENSION, |
---|
| 838 | FCMD_ISDIRECTORY, FCMD_ISFILE, FCMD_JOIN, FCMD_LINK, |
---|
| 839 | FCMD_LSTAT, FCMD_MTIME, FCMD_MKDIR, FCMD_NATIVENAME, |
---|
| 840 | FCMD_NORMALIZE, FCMD_OWNED, |
---|
| 841 | FCMD_PATHTYPE, FCMD_READABLE, FCMD_READLINK, FCMD_RENAME, |
---|
| 842 | FCMD_ROOTNAME, FCMD_SEPARATOR, FCMD_SIZE, FCMD_SPLIT, |
---|
| 843 | FCMD_STAT, FCMD_SYSTEM, |
---|
| 844 | FCMD_TAIL, FCMD_TYPE, FCMD_VOLUMES, FCMD_WRITABLE |
---|
| 845 | }; |
---|
| 846 | |
---|
| 847 | if (objc < 2) { |
---|
| 848 | Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); |
---|
| 849 | return TCL_ERROR; |
---|
| 850 | } |
---|
| 851 | if (Tcl_GetIndexFromObj(interp, objv[1], fileOptions, "option", 0, |
---|
| 852 | &index) != TCL_OK) { |
---|
| 853 | return TCL_ERROR; |
---|
| 854 | } |
---|
| 855 | |
---|
| 856 | switch ((enum options) index) { |
---|
| 857 | |
---|
| 858 | case FCMD_ATIME: |
---|
| 859 | case FCMD_MTIME: |
---|
| 860 | if ((objc < 3) || (objc > 4)) { |
---|
| 861 | Tcl_WrongNumArgs(interp, 2, objv, "name ?time?"); |
---|
| 862 | return TCL_ERROR; |
---|
| 863 | } |
---|
| 864 | if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { |
---|
| 865 | return TCL_ERROR; |
---|
| 866 | } |
---|
| 867 | if (objc == 4) { |
---|
| 868 | /* |
---|
| 869 | * Need separate variable for reading longs from an object on |
---|
| 870 | * 64-bit platforms. [Bug #698146] |
---|
| 871 | */ |
---|
| 872 | |
---|
| 873 | long newTime; |
---|
| 874 | |
---|
| 875 | if (TclGetLongFromObj(interp, objv[3], &newTime) != TCL_OK) { |
---|
| 876 | return TCL_ERROR; |
---|
| 877 | } |
---|
| 878 | |
---|
| 879 | if (index == FCMD_ATIME) { |
---|
| 880 | tval.actime = newTime; |
---|
| 881 | tval.modtime = buf.st_mtime; |
---|
| 882 | } else { /* index == FCMD_MTIME */ |
---|
| 883 | tval.actime = buf.st_atime; |
---|
| 884 | tval.modtime = newTime; |
---|
| 885 | } |
---|
| 886 | |
---|
| 887 | if (Tcl_FSUtime(objv[2], &tval) != 0) { |
---|
| 888 | Tcl_AppendResult(interp, "could not set ", |
---|
| 889 | (index == FCMD_ATIME ? "access" : "modification"), |
---|
| 890 | " time for file \"", TclGetString(objv[2]), "\": ", |
---|
| 891 | Tcl_PosixError(interp), NULL); |
---|
| 892 | return TCL_ERROR; |
---|
| 893 | } |
---|
| 894 | |
---|
| 895 | /* |
---|
| 896 | * Do another stat to ensure that the we return the new recognized |
---|
| 897 | * atime - hopefully the same as the one we sent in. However, fs's |
---|
| 898 | * like FAT don't even know what atime is. |
---|
| 899 | */ |
---|
| 900 | |
---|
| 901 | if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { |
---|
| 902 | return TCL_ERROR; |
---|
| 903 | } |
---|
| 904 | } |
---|
| 905 | |
---|
| 906 | Tcl_SetObjResult(interp, Tcl_NewLongObj((long) |
---|
| 907 | (index == FCMD_ATIME ? buf.st_atime : buf.st_mtime))); |
---|
| 908 | return TCL_OK; |
---|
| 909 | case FCMD_ATTRIBUTES: |
---|
| 910 | return TclFileAttrsCmd(interp, objc, objv); |
---|
| 911 | case FCMD_CHANNELS: |
---|
| 912 | if ((objc < 2) || (objc > 3)) { |
---|
| 913 | Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); |
---|
| 914 | return TCL_ERROR; |
---|
| 915 | } |
---|
| 916 | return Tcl_GetChannelNamesEx(interp, |
---|
| 917 | ((objc == 2) ? NULL : TclGetString(objv[2]))); |
---|
| 918 | case FCMD_COPY: |
---|
| 919 | return TclFileCopyCmd(interp, objc, objv); |
---|
| 920 | case FCMD_DELETE: |
---|
| 921 | return TclFileDeleteCmd(interp, objc, objv); |
---|
| 922 | case FCMD_DIRNAME: { |
---|
| 923 | Tcl_Obj *dirPtr; |
---|
| 924 | |
---|
| 925 | if (objc != 3) { |
---|
| 926 | goto only3Args; |
---|
| 927 | } |
---|
| 928 | dirPtr = TclPathPart(interp, objv[2], TCL_PATH_DIRNAME); |
---|
| 929 | if (dirPtr == NULL) { |
---|
| 930 | return TCL_ERROR; |
---|
| 931 | } else { |
---|
| 932 | Tcl_SetObjResult(interp, dirPtr); |
---|
| 933 | Tcl_DecrRefCount(dirPtr); |
---|
| 934 | return TCL_OK; |
---|
| 935 | } |
---|
| 936 | } |
---|
| 937 | case FCMD_EXECUTABLE: |
---|
| 938 | if (objc != 3) { |
---|
| 939 | goto only3Args; |
---|
| 940 | } |
---|
| 941 | return CheckAccess(interp, objv[2], X_OK); |
---|
| 942 | case FCMD_EXISTS: |
---|
| 943 | if (objc != 3) { |
---|
| 944 | goto only3Args; |
---|
| 945 | } |
---|
| 946 | return CheckAccess(interp, objv[2], F_OK); |
---|
| 947 | case FCMD_EXTENSION: { |
---|
| 948 | Tcl_Obj *ext; |
---|
| 949 | |
---|
| 950 | if (objc != 3) { |
---|
| 951 | goto only3Args; |
---|
| 952 | } |
---|
| 953 | ext = TclPathPart(interp, objv[2], TCL_PATH_EXTENSION); |
---|
| 954 | if (ext != NULL) { |
---|
| 955 | Tcl_SetObjResult(interp, ext); |
---|
| 956 | Tcl_DecrRefCount(ext); |
---|
| 957 | return TCL_OK; |
---|
| 958 | } else { |
---|
| 959 | return TCL_ERROR; |
---|
| 960 | } |
---|
| 961 | } |
---|
| 962 | case FCMD_ISDIRECTORY: |
---|
| 963 | if (objc != 3) { |
---|
| 964 | goto only3Args; |
---|
| 965 | } |
---|
| 966 | value = 0; |
---|
| 967 | if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { |
---|
| 968 | value = S_ISDIR(buf.st_mode); |
---|
| 969 | } |
---|
| 970 | Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); |
---|
| 971 | return TCL_OK; |
---|
| 972 | case FCMD_ISFILE: |
---|
| 973 | if (objc != 3) { |
---|
| 974 | goto only3Args; |
---|
| 975 | } |
---|
| 976 | value = 0; |
---|
| 977 | if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { |
---|
| 978 | value = S_ISREG(buf.st_mode); |
---|
| 979 | } |
---|
| 980 | Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); |
---|
| 981 | return TCL_OK; |
---|
| 982 | case FCMD_OWNED: |
---|
| 983 | if (objc != 3) { |
---|
| 984 | goto only3Args; |
---|
| 985 | } |
---|
| 986 | value = 0; |
---|
| 987 | if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { |
---|
| 988 | /* |
---|
| 989 | * For Windows, there are no user ids associated with a file, so |
---|
| 990 | * we always return 1. |
---|
| 991 | */ |
---|
| 992 | |
---|
| 993 | #if defined(__WIN32__) |
---|
| 994 | value = 1; |
---|
| 995 | #else |
---|
| 996 | value = (geteuid() == buf.st_uid); |
---|
| 997 | #endif |
---|
| 998 | } |
---|
| 999 | Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); |
---|
| 1000 | return TCL_OK; |
---|
| 1001 | case FCMD_JOIN: { |
---|
| 1002 | Tcl_Obj *resObj; |
---|
| 1003 | |
---|
| 1004 | if (objc < 3) { |
---|
| 1005 | Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?"); |
---|
| 1006 | return TCL_ERROR; |
---|
| 1007 | } |
---|
| 1008 | resObj = Tcl_FSJoinToPath(NULL, objc - 2, objv + 2); |
---|
| 1009 | Tcl_SetObjResult(interp, resObj); |
---|
| 1010 | return TCL_OK; |
---|
| 1011 | } |
---|
| 1012 | case FCMD_LINK: { |
---|
| 1013 | Tcl_Obj *contents; |
---|
| 1014 | int index; |
---|
| 1015 | |
---|
| 1016 | if (objc < 3 || objc > 5) { |
---|
| 1017 | Tcl_WrongNumArgs(interp, 2, objv, "?-linktype? linkname ?target?"); |
---|
| 1018 | return TCL_ERROR; |
---|
| 1019 | } |
---|
| 1020 | |
---|
| 1021 | /* |
---|
| 1022 | * Index of the 'source' argument. |
---|
| 1023 | */ |
---|
| 1024 | |
---|
| 1025 | if (objc == 5) { |
---|
| 1026 | index = 3; |
---|
| 1027 | } else { |
---|
| 1028 | index = 2; |
---|
| 1029 | } |
---|
| 1030 | |
---|
| 1031 | if (objc > 3) { |
---|
| 1032 | int linkAction; |
---|
| 1033 | if (objc == 5) { |
---|
| 1034 | /* |
---|
| 1035 | * We have a '-linktype' argument. |
---|
| 1036 | */ |
---|
| 1037 | |
---|
| 1038 | static CONST char *linkTypes[] = { |
---|
| 1039 | "-symbolic", "-hard", NULL |
---|
| 1040 | }; |
---|
| 1041 | if (Tcl_GetIndexFromObj(interp, objv[2], linkTypes, "switch", |
---|
| 1042 | 0, &linkAction) != TCL_OK) { |
---|
| 1043 | return TCL_ERROR; |
---|
| 1044 | } |
---|
| 1045 | if (linkAction == 0) { |
---|
| 1046 | linkAction = TCL_CREATE_SYMBOLIC_LINK; |
---|
| 1047 | } else { |
---|
| 1048 | linkAction = TCL_CREATE_HARD_LINK; |
---|
| 1049 | } |
---|
| 1050 | } else { |
---|
| 1051 | linkAction = TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK; |
---|
| 1052 | } |
---|
| 1053 | if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) { |
---|
| 1054 | return TCL_ERROR; |
---|
| 1055 | } |
---|
| 1056 | |
---|
| 1057 | /* |
---|
| 1058 | * Create link from source to target. |
---|
| 1059 | */ |
---|
| 1060 | |
---|
| 1061 | contents = Tcl_FSLink(objv[index], objv[index+1], linkAction); |
---|
| 1062 | if (contents == NULL) { |
---|
| 1063 | /* |
---|
| 1064 | * We handle three common error cases specially, and for all |
---|
| 1065 | * other errors, we use the standard posix error message. |
---|
| 1066 | */ |
---|
| 1067 | |
---|
| 1068 | if (errno == EEXIST) { |
---|
| 1069 | Tcl_AppendResult(interp, "could not create new link \"", |
---|
| 1070 | TclGetString(objv[index]), |
---|
| 1071 | "\": that path already exists", NULL); |
---|
| 1072 | } else if (errno == ENOENT) { |
---|
| 1073 | /* |
---|
| 1074 | * There are two cases here: either the target doesn't |
---|
| 1075 | * exist, or the directory of the src doesn't exist. |
---|
| 1076 | */ |
---|
| 1077 | |
---|
| 1078 | int access; |
---|
| 1079 | Tcl_Obj *dirPtr = TclPathPart(interp, objv[index], |
---|
| 1080 | TCL_PATH_DIRNAME); |
---|
| 1081 | |
---|
| 1082 | if (dirPtr == NULL) { |
---|
| 1083 | return TCL_ERROR; |
---|
| 1084 | } |
---|
| 1085 | access = Tcl_FSAccess(dirPtr, F_OK); |
---|
| 1086 | Tcl_DecrRefCount(dirPtr); |
---|
| 1087 | if (access != 0) { |
---|
| 1088 | Tcl_AppendResult(interp, |
---|
| 1089 | "could not create new link \"", |
---|
| 1090 | TclGetString(objv[index]), |
---|
| 1091 | "\": no such file or directory", NULL); |
---|
| 1092 | } else { |
---|
| 1093 | Tcl_AppendResult(interp, |
---|
| 1094 | "could not create new link \"", |
---|
| 1095 | TclGetString(objv[index]), "\": target \"", |
---|
| 1096 | TclGetString(objv[index+1]), |
---|
| 1097 | "\" doesn't exist", NULL); |
---|
| 1098 | } |
---|
| 1099 | } else { |
---|
| 1100 | Tcl_AppendResult(interp, |
---|
| 1101 | "could not create new link \"", |
---|
| 1102 | TclGetString(objv[index]), "\" pointing to \"", |
---|
| 1103 | TclGetString(objv[index+1]), "\": ", |
---|
| 1104 | Tcl_PosixError(interp), NULL); |
---|
| 1105 | } |
---|
| 1106 | return TCL_ERROR; |
---|
| 1107 | } |
---|
| 1108 | } else { |
---|
| 1109 | if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) { |
---|
| 1110 | return TCL_ERROR; |
---|
| 1111 | } |
---|
| 1112 | |
---|
| 1113 | /* |
---|
| 1114 | * Read link |
---|
| 1115 | */ |
---|
| 1116 | |
---|
| 1117 | contents = Tcl_FSLink(objv[index], NULL, 0); |
---|
| 1118 | if (contents == NULL) { |
---|
| 1119 | Tcl_AppendResult(interp, "could not read link \"", |
---|
| 1120 | TclGetString(objv[index]), "\": ", |
---|
| 1121 | Tcl_PosixError(interp), NULL); |
---|
| 1122 | return TCL_ERROR; |
---|
| 1123 | } |
---|
| 1124 | } |
---|
| 1125 | Tcl_SetObjResult(interp, contents); |
---|
| 1126 | if (objc == 3) { |
---|
| 1127 | /* |
---|
| 1128 | * If we are reading a link, we need to free this result refCount. |
---|
| 1129 | * If we are creating a link, this will just be objv[index+1], and |
---|
| 1130 | * so we don't own it. |
---|
| 1131 | */ |
---|
| 1132 | |
---|
| 1133 | Tcl_DecrRefCount(contents); |
---|
| 1134 | } |
---|
| 1135 | return TCL_OK; |
---|
| 1136 | } |
---|
| 1137 | case FCMD_LSTAT: |
---|
| 1138 | if (objc != 4) { |
---|
| 1139 | Tcl_WrongNumArgs(interp, 2, objv, "name varName"); |
---|
| 1140 | return TCL_ERROR; |
---|
| 1141 | } |
---|
| 1142 | if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) { |
---|
| 1143 | return TCL_ERROR; |
---|
| 1144 | } |
---|
| 1145 | return StoreStatData(interp, objv[3], &buf); |
---|
| 1146 | case FCMD_STAT: |
---|
| 1147 | if (objc != 4) { |
---|
| 1148 | Tcl_WrongNumArgs(interp, 2, objv, "name varName"); |
---|
| 1149 | return TCL_ERROR; |
---|
| 1150 | } |
---|
| 1151 | if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { |
---|
| 1152 | return TCL_ERROR; |
---|
| 1153 | } |
---|
| 1154 | return StoreStatData(interp, objv[3], &buf); |
---|
| 1155 | case FCMD_SIZE: |
---|
| 1156 | if (objc != 3) { |
---|
| 1157 | goto only3Args; |
---|
| 1158 | } |
---|
| 1159 | if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { |
---|
| 1160 | return TCL_ERROR; |
---|
| 1161 | } |
---|
| 1162 | Tcl_SetObjResult(interp, |
---|
| 1163 | Tcl_NewWideIntObj((Tcl_WideInt) buf.st_size)); |
---|
| 1164 | return TCL_OK; |
---|
| 1165 | case FCMD_TYPE: |
---|
| 1166 | if (objc != 3) { |
---|
| 1167 | goto only3Args; |
---|
| 1168 | } |
---|
| 1169 | if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) { |
---|
| 1170 | return TCL_ERROR; |
---|
| 1171 | } |
---|
| 1172 | Tcl_SetObjResult(interp, Tcl_NewStringObj( |
---|
| 1173 | GetTypeFromMode((unsigned short) buf.st_mode), -1)); |
---|
| 1174 | return TCL_OK; |
---|
| 1175 | case FCMD_MKDIR: |
---|
| 1176 | if (objc < 3) { |
---|
| 1177 | Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?"); |
---|
| 1178 | return TCL_ERROR; |
---|
| 1179 | } |
---|
| 1180 | return TclFileMakeDirsCmd(interp, objc, objv); |
---|
| 1181 | case FCMD_NATIVENAME: { |
---|
| 1182 | CONST char *fileName; |
---|
| 1183 | Tcl_DString ds; |
---|
| 1184 | |
---|
| 1185 | if (objc != 3) { |
---|
| 1186 | goto only3Args; |
---|
| 1187 | } |
---|
| 1188 | fileName = TclGetString(objv[2]); |
---|
| 1189 | fileName = Tcl_TranslateFileName(interp, fileName, &ds); |
---|
| 1190 | if (fileName == NULL) { |
---|
| 1191 | return TCL_ERROR; |
---|
| 1192 | } |
---|
| 1193 | Tcl_SetObjResult(interp, Tcl_NewStringObj(fileName, |
---|
| 1194 | Tcl_DStringLength(&ds))); |
---|
| 1195 | Tcl_DStringFree(&ds); |
---|
| 1196 | return TCL_OK; |
---|
| 1197 | } |
---|
| 1198 | case FCMD_NORMALIZE: { |
---|
| 1199 | Tcl_Obj *fileName; |
---|
| 1200 | |
---|
| 1201 | if (objc != 3) { |
---|
| 1202 | Tcl_WrongNumArgs(interp, 2, objv, "filename"); |
---|
| 1203 | return TCL_ERROR; |
---|
| 1204 | } |
---|
| 1205 | |
---|
| 1206 | fileName = Tcl_FSGetNormalizedPath(interp, objv[2]); |
---|
| 1207 | if (fileName == NULL) { |
---|
| 1208 | return TCL_ERROR; |
---|
| 1209 | } |
---|
| 1210 | Tcl_SetObjResult(interp, fileName); |
---|
| 1211 | return TCL_OK; |
---|
| 1212 | } |
---|
| 1213 | case FCMD_PATHTYPE: { |
---|
| 1214 | Tcl_Obj *typeName; |
---|
| 1215 | |
---|
| 1216 | if (objc != 3) { |
---|
| 1217 | goto only3Args; |
---|
| 1218 | } |
---|
| 1219 | |
---|
| 1220 | switch (Tcl_FSGetPathType(objv[2])) { |
---|
| 1221 | case TCL_PATH_ABSOLUTE: |
---|
| 1222 | TclNewLiteralStringObj(typeName, "absolute"); |
---|
| 1223 | break; |
---|
| 1224 | case TCL_PATH_RELATIVE: |
---|
| 1225 | TclNewLiteralStringObj(typeName, "relative"); |
---|
| 1226 | break; |
---|
| 1227 | case TCL_PATH_VOLUME_RELATIVE: |
---|
| 1228 | TclNewLiteralStringObj(typeName, "volumerelative"); |
---|
| 1229 | break; |
---|
| 1230 | default: |
---|
| 1231 | return TCL_OK; |
---|
| 1232 | } |
---|
| 1233 | Tcl_SetObjResult(interp, typeName); |
---|
| 1234 | return TCL_OK; |
---|
| 1235 | } |
---|
| 1236 | case FCMD_READABLE: |
---|
| 1237 | if (objc != 3) { |
---|
| 1238 | goto only3Args; |
---|
| 1239 | } |
---|
| 1240 | return CheckAccess(interp, objv[2], R_OK); |
---|
| 1241 | case FCMD_READLINK: { |
---|
| 1242 | Tcl_Obj *contents; |
---|
| 1243 | |
---|
| 1244 | if (objc != 3) { |
---|
| 1245 | goto only3Args; |
---|
| 1246 | } |
---|
| 1247 | |
---|
| 1248 | if (Tcl_FSConvertToPathType(interp, objv[2]) != TCL_OK) { |
---|
| 1249 | return TCL_ERROR; |
---|
| 1250 | } |
---|
| 1251 | |
---|
| 1252 | contents = Tcl_FSLink(objv[2], NULL, 0); |
---|
| 1253 | |
---|
| 1254 | if (contents == NULL) { |
---|
| 1255 | Tcl_AppendResult(interp, "could not readlink \"", |
---|
| 1256 | TclGetString(objv[2]), "\": ", Tcl_PosixError(interp), |
---|
| 1257 | NULL); |
---|
| 1258 | return TCL_ERROR; |
---|
| 1259 | } |
---|
| 1260 | Tcl_SetObjResult(interp, contents); |
---|
| 1261 | Tcl_DecrRefCount(contents); |
---|
| 1262 | return TCL_OK; |
---|
| 1263 | } |
---|
| 1264 | case FCMD_RENAME: |
---|
| 1265 | return TclFileRenameCmd(interp, objc, objv); |
---|
| 1266 | case FCMD_ROOTNAME: { |
---|
| 1267 | Tcl_Obj *root; |
---|
| 1268 | |
---|
| 1269 | if (objc != 3) { |
---|
| 1270 | goto only3Args; |
---|
| 1271 | } |
---|
| 1272 | root = TclPathPart(interp, objv[2], TCL_PATH_ROOT); |
---|
| 1273 | if (root != NULL) { |
---|
| 1274 | Tcl_SetObjResult(interp, root); |
---|
| 1275 | Tcl_DecrRefCount(root); |
---|
| 1276 | return TCL_OK; |
---|
| 1277 | } else { |
---|
| 1278 | return TCL_ERROR; |
---|
| 1279 | } |
---|
| 1280 | } |
---|
| 1281 | case FCMD_SEPARATOR: |
---|
| 1282 | if ((objc < 2) || (objc > 3)) { |
---|
| 1283 | Tcl_WrongNumArgs(interp, 2, objv, "?name?"); |
---|
| 1284 | return TCL_ERROR; |
---|
| 1285 | } |
---|
| 1286 | if (objc == 2) { |
---|
| 1287 | char *separator = NULL; /* lint */ |
---|
| 1288 | |
---|
| 1289 | switch (tclPlatform) { |
---|
| 1290 | case TCL_PLATFORM_UNIX: |
---|
| 1291 | separator = "/"; |
---|
| 1292 | break; |
---|
| 1293 | case TCL_PLATFORM_WINDOWS: |
---|
| 1294 | separator = "\\"; |
---|
| 1295 | break; |
---|
| 1296 | } |
---|
| 1297 | Tcl_SetObjResult(interp, Tcl_NewStringObj(separator, 1)); |
---|
| 1298 | } else { |
---|
| 1299 | Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[2]); |
---|
| 1300 | |
---|
| 1301 | if (separatorObj == NULL) { |
---|
| 1302 | Tcl_SetResult(interp, "Unrecognised path", TCL_STATIC); |
---|
| 1303 | return TCL_ERROR; |
---|
| 1304 | } |
---|
| 1305 | Tcl_SetObjResult(interp, separatorObj); |
---|
| 1306 | } |
---|
| 1307 | return TCL_OK; |
---|
| 1308 | case FCMD_SPLIT: { |
---|
| 1309 | Tcl_Obj *res; |
---|
| 1310 | |
---|
| 1311 | if (objc != 3) { |
---|
| 1312 | goto only3Args; |
---|
| 1313 | } |
---|
| 1314 | res = Tcl_FSSplitPath(objv[2], NULL); |
---|
| 1315 | if (res == NULL) { |
---|
| 1316 | /* How can the interp be NULL here?! DKF */ |
---|
| 1317 | if (interp != NULL) { |
---|
| 1318 | Tcl_AppendResult(interp, "could not read \"", |
---|
| 1319 | TclGetString(objv[2]), |
---|
| 1320 | "\": no such file or directory", NULL); |
---|
| 1321 | } |
---|
| 1322 | return TCL_ERROR; |
---|
| 1323 | } |
---|
| 1324 | Tcl_SetObjResult(interp, res); |
---|
| 1325 | return TCL_OK; |
---|
| 1326 | } |
---|
| 1327 | case FCMD_SYSTEM: { |
---|
| 1328 | Tcl_Obj *fsInfo; |
---|
| 1329 | |
---|
| 1330 | if (objc != 3) { |
---|
| 1331 | goto only3Args; |
---|
| 1332 | } |
---|
| 1333 | fsInfo = Tcl_FSFileSystemInfo(objv[2]); |
---|
| 1334 | if (fsInfo == NULL) { |
---|
| 1335 | Tcl_SetResult(interp, "Unrecognised path", TCL_STATIC); |
---|
| 1336 | return TCL_ERROR; |
---|
| 1337 | } |
---|
| 1338 | Tcl_SetObjResult(interp, fsInfo); |
---|
| 1339 | return TCL_OK; |
---|
| 1340 | } |
---|
| 1341 | case FCMD_TAIL: { |
---|
| 1342 | Tcl_Obj *dirPtr; |
---|
| 1343 | |
---|
| 1344 | if (objc != 3) { |
---|
| 1345 | goto only3Args; |
---|
| 1346 | } |
---|
| 1347 | dirPtr = TclPathPart(interp, objv[2], TCL_PATH_TAIL); |
---|
| 1348 | if (dirPtr == NULL) { |
---|
| 1349 | return TCL_ERROR; |
---|
| 1350 | } |
---|
| 1351 | Tcl_SetObjResult(interp, dirPtr); |
---|
| 1352 | Tcl_DecrRefCount(dirPtr); |
---|
| 1353 | return TCL_OK; |
---|
| 1354 | } |
---|
| 1355 | case FCMD_VOLUMES: |
---|
| 1356 | if (objc != 2) { |
---|
| 1357 | Tcl_WrongNumArgs(interp, 2, objv, NULL); |
---|
| 1358 | return TCL_ERROR; |
---|
| 1359 | } |
---|
| 1360 | Tcl_SetObjResult(interp, Tcl_FSListVolumes()); |
---|
| 1361 | return TCL_OK; |
---|
| 1362 | case FCMD_WRITABLE: |
---|
| 1363 | if (objc != 3) { |
---|
| 1364 | goto only3Args; |
---|
| 1365 | } |
---|
| 1366 | return CheckAccess(interp, objv[2], W_OK); |
---|
| 1367 | } |
---|
| 1368 | |
---|
| 1369 | only3Args: |
---|
| 1370 | Tcl_WrongNumArgs(interp, 2, objv, "name"); |
---|
| 1371 | return TCL_ERROR; |
---|
| 1372 | } |
---|
| 1373 | |
---|
| 1374 | /* |
---|
| 1375 | *--------------------------------------------------------------------------- |
---|
| 1376 | * |
---|
| 1377 | * CheckAccess -- |
---|
| 1378 | * |
---|
| 1379 | * Utility procedure used by Tcl_FileObjCmd() to query file attributes |
---|
| 1380 | * available through the access() system call. |
---|
| 1381 | * |
---|
| 1382 | * Results: |
---|
| 1383 | * Always returns TCL_OK. Sets interp's result to boolean true or false |
---|
| 1384 | * depending on whether the file has the specified attribute. |
---|
| 1385 | * |
---|
| 1386 | * Side effects: |
---|
| 1387 | * None. |
---|
| 1388 | * |
---|
| 1389 | *--------------------------------------------------------------------------- |
---|
| 1390 | */ |
---|
| 1391 | |
---|
| 1392 | static int |
---|
| 1393 | CheckAccess( |
---|
| 1394 | Tcl_Interp *interp, /* Interp for status return. Must not be |
---|
| 1395 | * NULL. */ |
---|
| 1396 | Tcl_Obj *pathPtr, /* Name of file to check. */ |
---|
| 1397 | int mode) /* Attribute to check; passed as argument to |
---|
| 1398 | * access(). */ |
---|
| 1399 | { |
---|
| 1400 | int value; |
---|
| 1401 | |
---|
| 1402 | if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) { |
---|
| 1403 | value = 0; |
---|
| 1404 | } else { |
---|
| 1405 | value = (Tcl_FSAccess(pathPtr, mode) == 0); |
---|
| 1406 | } |
---|
| 1407 | Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); |
---|
| 1408 | |
---|
| 1409 | return TCL_OK; |
---|
| 1410 | } |
---|
| 1411 | |
---|
| 1412 | /* |
---|
| 1413 | *--------------------------------------------------------------------------- |
---|
| 1414 | * |
---|
| 1415 | * GetStatBuf -- |
---|
| 1416 | * |
---|
| 1417 | * Utility procedure used by Tcl_FileObjCmd() to query file attributes |
---|
| 1418 | * available through the stat() or lstat() system call. |
---|
| 1419 | * |
---|
| 1420 | * Results: |
---|
| 1421 | * The return value is TCL_OK if the specified file exists and can be |
---|
| 1422 | * stat'ed, TCL_ERROR otherwise. If TCL_ERROR is returned, an error |
---|
| 1423 | * message is left in interp's result. If TCL_OK is returned, *statPtr is |
---|
| 1424 | * filled with information about the specified file. |
---|
| 1425 | * |
---|
| 1426 | * Side effects: |
---|
| 1427 | * None. |
---|
| 1428 | * |
---|
| 1429 | *--------------------------------------------------------------------------- |
---|
| 1430 | */ |
---|
| 1431 | |
---|
| 1432 | static int |
---|
| 1433 | GetStatBuf( |
---|
| 1434 | Tcl_Interp *interp, /* Interp for error return. May be NULL. */ |
---|
| 1435 | Tcl_Obj *pathPtr, /* Path name to examine. */ |
---|
| 1436 | Tcl_FSStatProc *statProc, /* Either stat() or lstat() depending on |
---|
| 1437 | * desired behavior. */ |
---|
| 1438 | Tcl_StatBuf *statPtr) /* Filled with info about file obtained by |
---|
| 1439 | * calling (*statProc)(). */ |
---|
| 1440 | { |
---|
| 1441 | int status; |
---|
| 1442 | |
---|
| 1443 | if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) { |
---|
| 1444 | return TCL_ERROR; |
---|
| 1445 | } |
---|
| 1446 | |
---|
| 1447 | status = (*statProc)(pathPtr, statPtr); |
---|
| 1448 | |
---|
| 1449 | if (status < 0) { |
---|
| 1450 | if (interp != NULL) { |
---|
| 1451 | Tcl_AppendResult(interp, "could not read \"", |
---|
| 1452 | TclGetString(pathPtr), "\": ", |
---|
| 1453 | Tcl_PosixError(interp), NULL); |
---|
| 1454 | } |
---|
| 1455 | return TCL_ERROR; |
---|
| 1456 | } |
---|
| 1457 | return TCL_OK; |
---|
| 1458 | } |
---|
| 1459 | |
---|
| 1460 | /* |
---|
| 1461 | *---------------------------------------------------------------------- |
---|
| 1462 | * |
---|
| 1463 | * StoreStatData -- |
---|
| 1464 | * |
---|
| 1465 | * This is a utility procedure that breaks out the fields of a "stat" |
---|
| 1466 | * structure and stores them in textual form into the elements of an |
---|
| 1467 | * associative array. |
---|
| 1468 | * |
---|
| 1469 | * Results: |
---|
| 1470 | * Returns a standard Tcl return value. If an error occurs then a message |
---|
| 1471 | * is left in interp's result. |
---|
| 1472 | * |
---|
| 1473 | * Side effects: |
---|
| 1474 | * Elements of the associative array given by "varName" are modified. |
---|
| 1475 | * |
---|
| 1476 | *---------------------------------------------------------------------- |
---|
| 1477 | */ |
---|
| 1478 | |
---|
| 1479 | static int |
---|
| 1480 | StoreStatData( |
---|
| 1481 | Tcl_Interp *interp, /* Interpreter for error reports. */ |
---|
| 1482 | Tcl_Obj *varName, /* Name of associative array variable in which |
---|
| 1483 | * to store stat results. */ |
---|
| 1484 | Tcl_StatBuf *statPtr) /* Pointer to buffer containing stat data to |
---|
| 1485 | * store in varName. */ |
---|
| 1486 | { |
---|
| 1487 | Tcl_Obj *field, *value; |
---|
| 1488 | register unsigned short mode; |
---|
| 1489 | |
---|
| 1490 | /* |
---|
| 1491 | * Assume Tcl_ObjSetVar2() does not keep a copy of the field name! |
---|
| 1492 | * |
---|
| 1493 | * Might be a better idea to call Tcl_SetVar2Ex() instead, except we want |
---|
| 1494 | * to have an object (i.e. possibly cached) array variable name but a |
---|
| 1495 | * string element name, so no API exists. Messy. |
---|
| 1496 | */ |
---|
| 1497 | |
---|
| 1498 | #define STORE_ARY(fieldName, object) \ |
---|
| 1499 | TclNewLiteralStringObj(field, fieldName); \ |
---|
| 1500 | Tcl_IncrRefCount(field); \ |
---|
| 1501 | value = (object); \ |
---|
| 1502 | if (Tcl_ObjSetVar2(interp,varName,field,value,TCL_LEAVE_ERR_MSG)==NULL) { \ |
---|
| 1503 | TclDecrRefCount(field); \ |
---|
| 1504 | return TCL_ERROR; \ |
---|
| 1505 | } \ |
---|
| 1506 | TclDecrRefCount(field); |
---|
| 1507 | |
---|
| 1508 | /* |
---|
| 1509 | * Watch out porters; the inode is meant to be an *unsigned* value, so the |
---|
| 1510 | * cast might fail when there isn't a real arithmentic 'long long' type... |
---|
| 1511 | */ |
---|
| 1512 | |
---|
| 1513 | STORE_ARY("dev", Tcl_NewLongObj((long)statPtr->st_dev)); |
---|
| 1514 | STORE_ARY("ino", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino)); |
---|
| 1515 | STORE_ARY("nlink", Tcl_NewLongObj((long)statPtr->st_nlink)); |
---|
| 1516 | STORE_ARY("uid", Tcl_NewLongObj((long)statPtr->st_uid)); |
---|
| 1517 | STORE_ARY("gid", Tcl_NewLongObj((long)statPtr->st_gid)); |
---|
| 1518 | STORE_ARY("size", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size)); |
---|
| 1519 | #ifdef HAVE_ST_BLOCKS |
---|
| 1520 | STORE_ARY("blocks", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_blocks)); |
---|
| 1521 | #endif |
---|
| 1522 | STORE_ARY("atime", Tcl_NewLongObj((long)statPtr->st_atime)); |
---|
| 1523 | STORE_ARY("mtime", Tcl_NewLongObj((long)statPtr->st_mtime)); |
---|
| 1524 | STORE_ARY("ctime", Tcl_NewLongObj((long)statPtr->st_ctime)); |
---|
| 1525 | mode = (unsigned short) statPtr->st_mode; |
---|
| 1526 | STORE_ARY("mode", Tcl_NewIntObj(mode)); |
---|
| 1527 | STORE_ARY("type", Tcl_NewStringObj(GetTypeFromMode(mode), -1)); |
---|
| 1528 | #undef STORE_ARY |
---|
| 1529 | |
---|
| 1530 | return TCL_OK; |
---|
| 1531 | } |
---|
| 1532 | |
---|
| 1533 | /* |
---|
| 1534 | *---------------------------------------------------------------------- |
---|
| 1535 | * |
---|
| 1536 | * GetTypeFromMode -- |
---|
| 1537 | * |
---|
| 1538 | * Given a mode word, returns a string identifying the type of a file. |
---|
| 1539 | * |
---|
| 1540 | * Results: |
---|
| 1541 | * A static text string giving the file type from mode. |
---|
| 1542 | * |
---|
| 1543 | * Side effects: |
---|
| 1544 | * None. |
---|
| 1545 | * |
---|
| 1546 | *---------------------------------------------------------------------- |
---|
| 1547 | */ |
---|
| 1548 | |
---|
| 1549 | static char * |
---|
| 1550 | GetTypeFromMode( |
---|
| 1551 | int mode) |
---|
| 1552 | { |
---|
| 1553 | if (S_ISREG(mode)) { |
---|
| 1554 | return "file"; |
---|
| 1555 | } else if (S_ISDIR(mode)) { |
---|
| 1556 | return "directory"; |
---|
| 1557 | } else if (S_ISCHR(mode)) { |
---|
| 1558 | return "characterSpecial"; |
---|
| 1559 | } else if (S_ISBLK(mode)) { |
---|
| 1560 | return "blockSpecial"; |
---|
| 1561 | } else if (S_ISFIFO(mode)) { |
---|
| 1562 | return "fifo"; |
---|
| 1563 | #ifdef S_ISLNK |
---|
| 1564 | } else if (S_ISLNK(mode)) { |
---|
| 1565 | return "link"; |
---|
| 1566 | #endif |
---|
| 1567 | #ifdef S_ISSOCK |
---|
| 1568 | } else if (S_ISSOCK(mode)) { |
---|
| 1569 | return "socket"; |
---|
| 1570 | #endif |
---|
| 1571 | } |
---|
| 1572 | return "unknown"; |
---|
| 1573 | } |
---|
| 1574 | |
---|
| 1575 | /* |
---|
| 1576 | *---------------------------------------------------------------------- |
---|
| 1577 | * |
---|
| 1578 | * Tcl_ForObjCmd -- |
---|
| 1579 | * |
---|
| 1580 | * This procedure is invoked to process the "for" Tcl command. See the |
---|
| 1581 | * user documentation for details on what it does. |
---|
| 1582 | * |
---|
| 1583 | * With the bytecode compiler, this procedure is only called when a |
---|
| 1584 | * command name is computed at runtime, and is "for" or the name to which |
---|
| 1585 | * "for" was renamed: e.g., |
---|
| 1586 | * "set z for; $z {set i 0} {$i<100} {incr i} {puts $i}" |
---|
| 1587 | * |
---|
| 1588 | * Results: |
---|
| 1589 | * A standard Tcl result. |
---|
| 1590 | * |
---|
| 1591 | * Side effects: |
---|
| 1592 | * See the user documentation. |
---|
| 1593 | * |
---|
| 1594 | *---------------------------------------------------------------------- |
---|
| 1595 | */ |
---|
| 1596 | |
---|
| 1597 | /* ARGSUSED */ |
---|
| 1598 | int |
---|
| 1599 | Tcl_ForObjCmd( |
---|
| 1600 | ClientData dummy, /* Not used. */ |
---|
| 1601 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 1602 | int objc, /* Number of arguments. */ |
---|
| 1603 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
| 1604 | { |
---|
| 1605 | int result, value; |
---|
| 1606 | Interp *iPtr = (Interp *) interp; |
---|
| 1607 | |
---|
| 1608 | if (objc != 5) { |
---|
| 1609 | Tcl_WrongNumArgs(interp, 1, objv, "start test next command"); |
---|
| 1610 | return TCL_ERROR; |
---|
| 1611 | } |
---|
| 1612 | |
---|
| 1613 | /* |
---|
| 1614 | * TIP #280. Make invoking context available to initial script. |
---|
| 1615 | */ |
---|
| 1616 | |
---|
| 1617 | result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1); |
---|
| 1618 | if (result != TCL_OK) { |
---|
| 1619 | if (result == TCL_ERROR) { |
---|
| 1620 | Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)"); |
---|
| 1621 | } |
---|
| 1622 | return result; |
---|
| 1623 | } |
---|
| 1624 | while (1) { |
---|
| 1625 | /* |
---|
| 1626 | * We need to reset the result before passing it off to |
---|
| 1627 | * Tcl_ExprBooleanObj. Otherwise, any error message will be appended |
---|
| 1628 | * to the result of the last evaluation. |
---|
| 1629 | */ |
---|
| 1630 | |
---|
| 1631 | Tcl_ResetResult(interp); |
---|
| 1632 | result = Tcl_ExprBooleanObj(interp, objv[2], &value); |
---|
| 1633 | if (result != TCL_OK) { |
---|
| 1634 | return result; |
---|
| 1635 | } |
---|
| 1636 | if (!value) { |
---|
| 1637 | break; |
---|
| 1638 | } |
---|
| 1639 | |
---|
| 1640 | /* |
---|
| 1641 | * TIP #280. Make invoking context available to loop body. |
---|
| 1642 | */ |
---|
| 1643 | |
---|
| 1644 | result = TclEvalObjEx(interp, objv[4], 0, iPtr->cmdFramePtr, 4); |
---|
| 1645 | if ((result != TCL_OK) && (result != TCL_CONTINUE)) { |
---|
| 1646 | if (result == TCL_ERROR) { |
---|
| 1647 | Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( |
---|
| 1648 | "\n (\"for\" body line %d)", interp->errorLine)); |
---|
| 1649 | } |
---|
| 1650 | break; |
---|
| 1651 | } |
---|
| 1652 | |
---|
| 1653 | /* |
---|
| 1654 | * TIP #280. Make invoking context available to next script. |
---|
| 1655 | */ |
---|
| 1656 | |
---|
| 1657 | result = TclEvalObjEx(interp, objv[3], 0, iPtr->cmdFramePtr, 3); |
---|
| 1658 | if (result == TCL_BREAK) { |
---|
| 1659 | break; |
---|
| 1660 | } else if (result != TCL_OK) { |
---|
| 1661 | if (result == TCL_ERROR) { |
---|
| 1662 | Tcl_AddErrorInfo(interp, "\n (\"for\" loop-end command)"); |
---|
| 1663 | } |
---|
| 1664 | return result; |
---|
| 1665 | } |
---|
| 1666 | } |
---|
| 1667 | if (result == TCL_BREAK) { |
---|
| 1668 | result = TCL_OK; |
---|
| 1669 | } |
---|
| 1670 | if (result == TCL_OK) { |
---|
| 1671 | Tcl_ResetResult(interp); |
---|
| 1672 | } |
---|
| 1673 | return result; |
---|
| 1674 | } |
---|
| 1675 | |
---|
| 1676 | /* |
---|
| 1677 | *---------------------------------------------------------------------- |
---|
| 1678 | * |
---|
| 1679 | * Tcl_ForeachObjCmd -- |
---|
| 1680 | * |
---|
| 1681 | * This object-based procedure is invoked to process the "foreach" Tcl |
---|
| 1682 | * command. See the user documentation for details on what it does. |
---|
| 1683 | * |
---|
| 1684 | * Results: |
---|
| 1685 | * A standard Tcl object result. |
---|
| 1686 | * |
---|
| 1687 | * Side effects: |
---|
| 1688 | * See the user documentation. |
---|
| 1689 | * |
---|
| 1690 | *---------------------------------------------------------------------- |
---|
| 1691 | */ |
---|
| 1692 | |
---|
| 1693 | /* ARGSUSED */ |
---|
| 1694 | int |
---|
| 1695 | Tcl_ForeachObjCmd( |
---|
| 1696 | ClientData dummy, /* Not used. */ |
---|
| 1697 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 1698 | int objc, /* Number of arguments. */ |
---|
| 1699 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
| 1700 | { |
---|
| 1701 | int result = TCL_OK; |
---|
| 1702 | int i; /* i selects a value list */ |
---|
| 1703 | int j, maxj; /* Number of loop iterations */ |
---|
| 1704 | int v; /* v selects a loop variable */ |
---|
| 1705 | int numLists = (objc-2)/2; /* Count of value lists */ |
---|
| 1706 | Tcl_Obj *bodyPtr; |
---|
| 1707 | Interp *iPtr = (Interp *) interp; |
---|
| 1708 | |
---|
| 1709 | int *index; /* Array of value list indices */ |
---|
| 1710 | int *varcList; /* # loop variables per list */ |
---|
| 1711 | Tcl_Obj ***varvList; /* Array of var name lists */ |
---|
| 1712 | Tcl_Obj **vCopyList; /* Copies of var name list arguments */ |
---|
| 1713 | int *argcList; /* Array of value list sizes */ |
---|
| 1714 | Tcl_Obj ***argvList; /* Array of value lists */ |
---|
| 1715 | Tcl_Obj **aCopyList; /* Copies of value list arguments */ |
---|
| 1716 | |
---|
| 1717 | if (objc < 4 || (objc%2 != 0)) { |
---|
| 1718 | Tcl_WrongNumArgs(interp, 1, objv, |
---|
| 1719 | "varList list ?varList list ...? command"); |
---|
| 1720 | return TCL_ERROR; |
---|
| 1721 | } |
---|
| 1722 | |
---|
| 1723 | /* |
---|
| 1724 | * Manage numList parallel value lists. |
---|
| 1725 | * argvList[i] is a value list counted by argcList[i]l; |
---|
| 1726 | * varvList[i] is the list of variables associated with the value list; |
---|
| 1727 | * varcList[i] is the number of variables associated with the value list; |
---|
| 1728 | * index[i] is the current pointer into the value list argvList[i]. |
---|
| 1729 | */ |
---|
| 1730 | |
---|
| 1731 | index = (int *) TclStackAlloc(interp, 3 * numLists * sizeof(int)); |
---|
| 1732 | varcList = index + numLists; |
---|
| 1733 | argcList = varcList + numLists; |
---|
| 1734 | memset(index, 0, 3 * numLists * sizeof(int)); |
---|
| 1735 | |
---|
| 1736 | varvList = (Tcl_Obj ***) |
---|
| 1737 | TclStackAlloc(interp, 2 * numLists * sizeof(Tcl_Obj **)); |
---|
| 1738 | argvList = varvList + numLists; |
---|
| 1739 | memset(varvList, 0, 2 * numLists * sizeof(Tcl_Obj **)); |
---|
| 1740 | |
---|
| 1741 | vCopyList = (Tcl_Obj **) |
---|
| 1742 | TclStackAlloc(interp, 2 * numLists * sizeof(Tcl_Obj *)); |
---|
| 1743 | aCopyList = vCopyList + numLists; |
---|
| 1744 | memset(vCopyList, 0, 2 * numLists * sizeof(Tcl_Obj *)); |
---|
| 1745 | |
---|
| 1746 | /* |
---|
| 1747 | * Break up the value lists and variable lists into elements. |
---|
| 1748 | */ |
---|
| 1749 | |
---|
| 1750 | maxj = 0; |
---|
| 1751 | for (i=0 ; i<numLists ; i++) { |
---|
| 1752 | |
---|
| 1753 | vCopyList[i] = TclListObjCopy(interp, objv[1+i*2]); |
---|
| 1754 | if (vCopyList[i] == NULL) { |
---|
| 1755 | result = TCL_ERROR; |
---|
| 1756 | goto done; |
---|
| 1757 | } |
---|
| 1758 | TclListObjGetElements(NULL, vCopyList[i], &varcList[i], &varvList[i]); |
---|
| 1759 | if (varcList[i] < 1) { |
---|
| 1760 | Tcl_AppendResult(interp, "foreach varlist is empty", NULL); |
---|
| 1761 | result = TCL_ERROR; |
---|
| 1762 | goto done; |
---|
| 1763 | } |
---|
| 1764 | |
---|
| 1765 | aCopyList[i] = TclListObjCopy(interp, objv[2+i*2]); |
---|
| 1766 | if (aCopyList[i] == NULL) { |
---|
| 1767 | result = TCL_ERROR; |
---|
| 1768 | goto done; |
---|
| 1769 | } |
---|
| 1770 | TclListObjGetElements(NULL, aCopyList[i], &argcList[i], &argvList[i]); |
---|
| 1771 | |
---|
| 1772 | j = argcList[i] / varcList[i]; |
---|
| 1773 | if ((argcList[i] % varcList[i]) != 0) { |
---|
| 1774 | j++; |
---|
| 1775 | } |
---|
| 1776 | if (j > maxj) { |
---|
| 1777 | maxj = j; |
---|
| 1778 | } |
---|
| 1779 | } |
---|
| 1780 | |
---|
| 1781 | /* |
---|
| 1782 | * Iterate maxj times through the lists in parallel. If some value lists |
---|
| 1783 | * run out of values, set loop vars to "" |
---|
| 1784 | */ |
---|
| 1785 | |
---|
| 1786 | bodyPtr = objv[objc-1]; |
---|
| 1787 | for (j=0 ; j<maxj ; j++) { |
---|
| 1788 | for (i=0 ; i<numLists ; i++) { |
---|
| 1789 | for (v=0 ; v<varcList[i] ; v++) { |
---|
| 1790 | int k = index[i]++; |
---|
| 1791 | Tcl_Obj *valuePtr, *varValuePtr; |
---|
| 1792 | |
---|
| 1793 | if (k < argcList[i]) { |
---|
| 1794 | valuePtr = argvList[i][k]; |
---|
| 1795 | } else { |
---|
| 1796 | valuePtr = Tcl_NewObj(); /* Empty string */ |
---|
| 1797 | } |
---|
| 1798 | varValuePtr = Tcl_ObjSetVar2(interp, varvList[i][v], NULL, |
---|
| 1799 | valuePtr, TCL_LEAVE_ERR_MSG); |
---|
| 1800 | if (varValuePtr == NULL) { |
---|
| 1801 | Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( |
---|
| 1802 | "\n (setting foreach loop variable \"%s\")", |
---|
| 1803 | TclGetString(varvList[i][v]))); |
---|
| 1804 | result = TCL_ERROR; |
---|
| 1805 | goto done; |
---|
| 1806 | } |
---|
| 1807 | } |
---|
| 1808 | } |
---|
| 1809 | |
---|
| 1810 | /* |
---|
| 1811 | * TIP #280. Make invoking context available to loop body. |
---|
| 1812 | */ |
---|
| 1813 | |
---|
| 1814 | result = TclEvalObjEx(interp, bodyPtr, 0, iPtr->cmdFramePtr, objc-1); |
---|
| 1815 | if (result != TCL_OK) { |
---|
| 1816 | if (result == TCL_CONTINUE) { |
---|
| 1817 | result = TCL_OK; |
---|
| 1818 | } else if (result == TCL_BREAK) { |
---|
| 1819 | result = TCL_OK; |
---|
| 1820 | break; |
---|
| 1821 | } else if (result == TCL_ERROR) { |
---|
| 1822 | Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( |
---|
| 1823 | "\n (\"foreach\" body line %d)", |
---|
| 1824 | interp->errorLine)); |
---|
| 1825 | break; |
---|
| 1826 | } else { |
---|
| 1827 | break; |
---|
| 1828 | } |
---|
| 1829 | } |
---|
| 1830 | } |
---|
| 1831 | if (result == TCL_OK) { |
---|
| 1832 | Tcl_ResetResult(interp); |
---|
| 1833 | } |
---|
| 1834 | |
---|
| 1835 | done: |
---|
| 1836 | for (i=0 ; i<numLists ; i++) { |
---|
| 1837 | if (vCopyList[i]) { |
---|
| 1838 | Tcl_DecrRefCount(vCopyList[i]); |
---|
| 1839 | } |
---|
| 1840 | if (aCopyList[i]) { |
---|
| 1841 | Tcl_DecrRefCount(aCopyList[i]); |
---|
| 1842 | } |
---|
| 1843 | } |
---|
| 1844 | TclStackFree(interp, vCopyList); /* Tcl_Obj * arrays */ |
---|
| 1845 | TclStackFree(interp, varvList); /* Tcl_Obj ** arrays */ |
---|
| 1846 | TclStackFree(interp, index); /* int arrays */ |
---|
| 1847 | return result; |
---|
| 1848 | } |
---|
| 1849 | |
---|
| 1850 | /* |
---|
| 1851 | *---------------------------------------------------------------------- |
---|
| 1852 | * |
---|
| 1853 | * Tcl_FormatObjCmd -- |
---|
| 1854 | * |
---|
| 1855 | * This procedure is invoked to process the "format" Tcl command. See |
---|
| 1856 | * the user documentation for details on what it does. |
---|
| 1857 | * |
---|
| 1858 | * Results: |
---|
| 1859 | * A standard Tcl result. |
---|
| 1860 | * |
---|
| 1861 | * Side effects: |
---|
| 1862 | * See the user documentation. |
---|
| 1863 | * |
---|
| 1864 | *---------------------------------------------------------------------- |
---|
| 1865 | */ |
---|
| 1866 | |
---|
| 1867 | /* ARGSUSED */ |
---|
| 1868 | int |
---|
| 1869 | Tcl_FormatObjCmd( |
---|
| 1870 | ClientData dummy, /* Not used. */ |
---|
| 1871 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 1872 | int objc, /* Number of arguments. */ |
---|
| 1873 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
| 1874 | { |
---|
| 1875 | Tcl_Obj *resultPtr; /* Where result is stored finally. */ |
---|
| 1876 | |
---|
| 1877 | if (objc < 2) { |
---|
| 1878 | Tcl_WrongNumArgs(interp, 1, objv, "formatString ?arg arg ...?"); |
---|
| 1879 | return TCL_ERROR; |
---|
| 1880 | } |
---|
| 1881 | |
---|
| 1882 | resultPtr = Tcl_Format(interp, TclGetString(objv[1]), objc-2, objv+2); |
---|
| 1883 | if (resultPtr == NULL) { |
---|
| 1884 | return TCL_ERROR; |
---|
| 1885 | } |
---|
| 1886 | Tcl_SetObjResult(interp, resultPtr); |
---|
| 1887 | return TCL_OK; |
---|
| 1888 | } |
---|
| 1889 | |
---|
| 1890 | /* |
---|
| 1891 | * Local Variables: |
---|
| 1892 | * mode: c |
---|
| 1893 | * c-basic-offset: 4 |
---|
| 1894 | * fill-column: 78 |
---|
| 1895 | * End: |
---|
| 1896 | */ |
---|