1/* 2 * tclXwinOS.c -- 3 * 4 * OS system dependent interface for Windows systems. The idea behind these 5 * functions is to provide interfaces to various functions that vary on the 6 * various platforms. These functions either implement the call in a manner 7 * approriate to the platform or return an error indicating the functionality 8 * is not available on that platform. This results in code with minimal 9 * number of #ifdefs. 10 *----------------------------------------------------------------------------- 11 * Copyright 1996-1999 Karl Lehenbauer and Mark Diekhans. 12 * 13 * Permission to use, copy, modify, and distribute this software and its 14 * documentation for any purpose and without fee is hereby granted, provided 15 * that the above copyright notice appear in all copies. Karl Lehenbauer and 16 * Mark Diekhans make no representations about the suitability of this 17 * software for any purpose. It is provided "as is" without express or 18 * implied warranty. 19 *----------------------------------------------------------------------------- 20 * $Id: tclXwinOS.c,v 1.8 2005/07/12 19:03:15 hobbs Exp $ 21 *----------------------------------------------------------------------------- 22 * The code for reading directories is based on TclMatchFiles from the Tcl 23 * distribution file win/tclWinFile.c 24 * Copyright (c) 1995 Sun Microsystems, Inc. 25 *----------------------------------------------------------------------------- 26 */ 27 28#include "tclExtdInt.h" 29 30typedef enum { 31 TCLX_WIN_CONSOLE, 32 TCLX_WIN_FILE, 33 TCLX_WIN_PIPE, 34 TCLX_WIN_SOCKET 35} tclXwinFileType; 36 37 38/*----------------------------------------------------------------------------- 39 * TclXNotAvailableError -- 40 * Return an error about functionality not being available under Windows. 41 * 42 * Parameters: 43 * o interp - Errors returned in result. 44 * o funcName - Command or other name to use in not available error. 45 * Returns: 46 * TCL_ERROR. 47 *----------------------------------------------------------------------------- 48 */ 49int 50TclXNotAvailableError (Tcl_Interp *interp, 51 char *funcName) 52{ 53 Tcl_AppendResult(interp, funcName, " is not available on MS Windows", 54 (char *) NULL); 55 return TCL_ERROR; 56} 57int 58TclXNotAvailableObjError (Tcl_Interp *interp, 59 Tcl_Obj *obj) 60{ 61 char *funcName = Tcl_GetStringFromObj(obj, NULL); 62 63 Tcl_AppendResult(interp, funcName, " is not available on MS Windows", 64 (char *) NULL); 65 return TCL_ERROR; 66} 67 68 69/*----------------------------------------------------------------------------- 70 * TclX_SplitWinCmdLine -- 71 * Parse the window command line into arguments. 72 * 73 * Parameters: 74 * o argcPtr - Count of arguments is returned here. 75 * o argvPtr - Argument vector is returned here. 76 * Notes: 77 * This code taken from the Tcl file tclAppInit.c: Copyright (c) 1996 by 78 * Sun Microsystems, Inc. 79 *----------------------------------------------------------------------------- 80 */ 81 82/* 83 *------------------------------------------------------------------------- 84 * 85 * setargv -- 86 * 87 * Parse the Windows command line string into argc/argv. Done here 88 * because we don't trust the builtin argument parser in crt0. 89 * Windows applications are responsible for breaking their command 90 * line into arguments. 91 * 92 * 2N backslashes + quote -> N backslashes + begin quoted string 93 * 2N + 1 backslashes + quote -> literal 94 * N backslashes + non-quote -> literal 95 * quote + quote in a quoted string -> single quote 96 * quote + quote not in quoted string -> empty string 97 * quote -> begin quoted string 98 * 99 * Results: 100 * Fills argcPtr with the number of arguments and argvPtr with the 101 * array of arguments. 102 * 103 * Side effects: 104 * Memory allocated. 105 * 106 *-------------------------------------------------------------------------- 107 */ 108void 109TclX_SplitWinCmdLine (int *argcPtr, 110 char ***argvPtr) 111{ 112 char *cmdLine, *p, *arg, *argSpace; 113 char **argv; 114 int argc, size, inquote, copy, slashes; 115 116 cmdLine = GetCommandLine(); 117 118 /* 119 * Precompute an overly pessimistic guess at the number of arguments 120 * in the command line by counting non-space spans. 121 */ 122 123 size = 2; 124 for (p = cmdLine; *p != '\0'; p++) { 125 if (isspace(*p)) { 126 size++; 127 while (isspace(*p)) { 128 p++; 129 } 130 if (*p == '\0') { 131 break; 132 } 133 } 134 } 135 argSpace = (char *) ckalloc((unsigned) (size * sizeof(char *) 136 + strlen(cmdLine) + 1)); 137 argv = (char **) argSpace; 138 argSpace += size * sizeof(char *); 139 size--; 140 141 p = cmdLine; 142 for (argc = 0; argc < size; argc++) { 143 argv[argc] = arg = argSpace; 144 while (isspace(*p)) { 145 p++; 146 } 147 if (*p == '\0') { 148 break; 149 } 150 151 inquote = 0; 152 slashes = 0; 153 while (1) { 154 copy = 1; 155 while (*p == '\\') { 156 slashes++; 157 p++; 158 } 159 if (*p == '"') { 160 if ((slashes & 1) == 0) { 161 copy = 0; 162 if ((inquote) && (p[1] == '"')) { 163 p++; 164 copy = 1; 165 } else { 166 inquote = !inquote; 167 } 168 } 169 slashes >>= 1; 170 } 171 172 while (slashes) { 173 *arg = '\\'; 174 arg++; 175 slashes--; 176 } 177 178 if ((*p == '\0') || (!inquote && isspace(*p))) { 179 break; 180 } 181 if (copy != 0) { 182 *arg = *p; 183 arg++; 184 } 185 p++; 186 } 187 *arg = '\0'; 188 argSpace = arg + 1; 189 } 190 argv[argc] = NULL; 191 192 *argcPtr = argc; 193 *argvPtr = argv; 194} 195 196 197/*----------------------------------------------------------------------------- 198 * ChannelToHandle -- 199 * 200 * Convert a channel to a handle. 201 * 202 * Parameters: 203 * o channel - Channel to get file number for. 204 * o direction - TCL_READABLE or TCL_WRITABLE, or zero. If zero, then 205 * return the first of the read and write numbers. 206 * o type - The type of the file. not set if an error occurs. 207 * 208 * Returns: 209 * The file handle or INVALID_HANDLE_VALUE if a HANDLE is not associated 210 * with this access direction, or if the channel does not have a HANDLE 211 * of the Windows variety. We hope that the channel driver does not return 212 * a HANDLE that we cannot use. 213 *----------------------------------------------------------------------------- 214 */ 215static HANDLE 216ChannelToHandle (Tcl_Channel channel, 217 int direction, 218 tclXwinFileType *typePtr) 219{ 220 ClientData handle; 221 int sockType; 222 int sockTypeLen = sizeof(sockType); 223 224 if (direction == 0) { 225 if (Tcl_GetChannelHandle (channel, TCL_READABLE, &handle) != TCL_OK && 226 Tcl_GetChannelHandle (channel, TCL_WRITABLE, &handle) != TCL_OK) { 227 handle = INVALID_HANDLE_VALUE; 228 } 229 } else { 230 if (Tcl_GetChannelHandle (channel, direction, &handle) != TCL_OK) { 231 handle = INVALID_HANDLE_VALUE; 232 } 233 } 234 235 /* 236 * Call GetFileType() even on invalid handles to set errno, 237 * also will coerce INVALID_SOCKET to INVALID_HANDLE, they 238 * may not be the same on some machines. 239 */ 240 switch (GetFileType ((HANDLE) handle)) { 241 case FILE_TYPE_DISK: 242 *typePtr = TCLX_WIN_FILE; 243 break; 244 case FILE_TYPE_CHAR: 245 *typePtr = TCLX_WIN_CONSOLE; 246 break; 247 case FILE_TYPE_PIPE: 248 if (getsockopt ((SOCKET)handle, SOL_SOCKET, SO_TYPE, 249 (void *)&sockType, &sockTypeLen) == 0) { 250 *typePtr = TCLX_WIN_SOCKET; 251 } else { 252 *typePtr = TCLX_WIN_PIPE; 253 } 254 break; 255 case FILE_TYPE_UNKNOWN: 256 handle = INVALID_HANDLE_VALUE; 257 break; 258 } 259 260 return (HANDLE) handle; 261} 262 263/*----------------------------------------------------------------------------- 264 * ChannelToSocket -- 265 * 266 * Convert a channel to a socket. 267 * 268 * Parameters: 269 * o interp - An error is returned if the channel is not a socket. 270 * o channel - Channel to get file number for. 271 * Returns: 272 * The socket number or INVALID_SOCKET if an error occurs. 273 *----------------------------------------------------------------------------- 274 */ 275static SOCKET 276ChannelToSocket (Tcl_Interp *interp, 277 Tcl_Channel channel) 278{ 279 ClientData handle; 280 tclXwinFileType type; 281 282 handle = ChannelToHandle(channel, 0, &type); 283 284 if (handle == INVALID_HANDLE_VALUE || type != TCLX_WIN_SOCKET) { 285 TclX_AppendObjResult (interp, "channel \"", 286 Tcl_GetChannelName (channel), 287 "\" is not a socket", (char *) NULL); 288 return INVALID_SOCKET; 289 } 290 291 return (SOCKET) handle; 292} 293 294/*----------------------------------------------------------------------------- 295 * ConvertToUnixTime -- 296 * 297 * Convert a FILETIME structure to Unix style time. 298 * 299 * Parameters: 300 * o fileTime - Time to convert. 301 * Returns: 302 * Unix time: seconds since Jan 1, 1970. 303 *----------------------------------------------------------------------------- 304 */ 305static time_t 306ConvertToUnixTime (FILETIME fileTime) 307{ 308 /* FIX: Write me */ 309 return 0; 310} 311 312/*----------------------------------------------------------------------------- 313 * TclXOSgetpriority -- 314 * System dependent interface to getpriority functionality, which is not 315 * available* on windows. 316 * 317 * Parameters: 318 * o interp - Errors returned in result. 319 * o priority - Process priority is returned here. 320 * o funcName - Command or other name to use in not available error. 321 * Results: 322 * TCL_ERROR. 323 *----------------------------------------------------------------------------- 324 */ 325int 326TclXOSgetpriority (Tcl_Interp *interp, 327 int *priority, 328 char *funcName) 329{ 330 /*FIX: this should work */ 331 return TclXNotAvailableError (interp, funcName); 332} 333 334/*----------------------------------------------------------------------------- 335 * TclXOSincrpriority-- 336 * System dependent interface to increment or decrement the current priority, 337 * which is not available on windows. 338 * 339 * Parameters: 340 * o interp - Errors returned in result. 341 * o priorityIncr - Amount to adjust the priority by. 342 * o priority - The new priority.. 343 * o funcName - Command or other name to use in not available error. 344 * Results: 345 * TCL_ERROR. 346 *----------------------------------------------------------------------------- 347 */ 348int 349TclXOSincrpriority (Tcl_Interp *interp, 350 int priorityIncr, 351 int *priority, 352 char *funcName) 353{ 354 return TclXNotAvailableError (interp, funcName); 355} 356 357/*----------------------------------------------------------------------------- 358 * TclXOSpipe -- 359 * System dependent interface to create a pipes for the pipe command. 360 * 361 * Parameters: 362 * o interp - Errors returned in result. 363 * o channels - Two element array to return read and write channels in. 364 * Results: 365 * TCL_OK or TCL_ERROR. 366 *----------------------------------------------------------------------------- 367 */ 368int 369TclXOSpipe (interp, channels) 370 Tcl_Interp *interp; 371 Tcl_Channel *channels; 372{ 373 HANDLE readHandle, writeHandle; 374 SECURITY_ATTRIBUTES sec; 375 376 sec.nLength = sizeof(SECURITY_ATTRIBUTES); 377 sec.lpSecurityDescriptor = NULL; 378 sec.bInheritHandle = FALSE; 379 380 if (!CreatePipe (&readHandle, &writeHandle, &sec, 0)) { 381 TclWinConvertError (GetLastError ()); 382 TclX_AppendObjResult (interp, "pipe creation failed: ", 383 Tcl_PosixError (interp), (char *) NULL); 384 return TCL_ERROR; 385 } 386 387 channels [0] = Tcl_MakeFileChannel ((ClientData) readHandle, 388 TCL_READABLE); 389 Tcl_RegisterChannel (interp, channels [0]); 390 391 channels [1] = Tcl_MakeFileChannel ((ClientData) writeHandle, 392 TCL_WRITABLE); 393 Tcl_RegisterChannel (interp, channels [1]); 394 395 return TCL_OK; 396} 397 398/*----------------------------------------------------------------------------- 399 * TclXOSsetitimer -- 400 * System dependent interface to setitimer functionality, which is not 401 * available on windows. 402 * 403 * Parameters: 404 * o interp - Errors returned in result. 405 * o seconds (I/O) - Seconds to pause for, it is updated with the time 406 * remaining on the last alarm. 407 * o funcName - Command or other name to use in not available error. 408 * Results: 409 * TCL_ERROR. 410 *----------------------------------------------------------------------------- 411 */ 412int 413TclXOSsetitimer (Tcl_Interp *interp, 414 double *seconds, 415 char *funcName) 416{ 417 return TclXNotAvailableError (interp, funcName); 418} 419 420/*----------------------------------------------------------------------------- 421 * TclXOSsleep -- 422 * System dependent interface to sleep functionality. 423 * 424 * Parameters: 425 * o seconds - Seconds to sleep. 426 *----------------------------------------------------------------------------- 427 */ 428void 429TclXOSsleep (unsigned seconds) 430{ 431 Tcl_Sleep(seconds*1000); 432} 433 434/*----------------------------------------------------------------------------- 435 * TclXOSsync -- 436 * System dependent interface to sync functionality. 437 *----------------------------------------------------------------------------- 438 */ 439void 440TclXOSsync () 441{ 442 _flushall (); 443} 444 445/*----------------------------------------------------------------------------- 446 * TclXOSfsync -- 447 * System dependent interface to fsync functionality. Does a _flushall, 448 * since fsync is not available. 449 * 450 * Parameters: 451 * o interp - Errors returned in result. 452 * o channel - The channel to sync. 453 * Results: 454 * TCL_OK or TCL_ERROR. 455 *----------------------------------------------------------------------------- 456 */ 457int 458TclXOSfsync (Tcl_Interp *interp, 459 Tcl_Channel channel) 460{ 461 if (Tcl_Flush (channel) < 0) 462 goto posixError; 463 464 _flushall (); 465 return TCL_OK; 466 467 posixError: 468 TclX_AppendObjResult (interp, Tcl_PosixError (interp), (char *) NULL); 469 return TCL_ERROR; 470} 471 472/*----------------------------------------------------------------------------- 473 * TclXOSsystem -- 474 * System dependent interface to system functionality (executing a command 475 * with the standard system shell). 476 * 477 * Parameters: 478 * o interp - Errors returned in result. 479 * o command - Command to execute. 480 * o exitCode - Exit code of the child process. 481 * Results: 482 * TCL_OK or TCL_ERROR. 483 *----------------------------------------------------------------------------- 484 */ 485int 486TclXOSsystem (Tcl_Interp *interp, 487 char *command, 488 int *exitCode) 489{ 490 PROCESS_INFORMATION pi; 491 STARTUPINFO si; 492 BOOL bSuccess; 493 494 memset (&si, 0, sizeof (si)); 495 496 bSuccess = CreateProcess (command, 497 NULL, NULL, NULL, 498 0, 499 CREATE_NEW_PROCESS_GROUP, 500 NULL, NULL, 501 &si, &pi); 502 if (!bSuccess) { 503 TclX_AppendObjResult (interp, "process creation failed", 504 (char *) NULL); 505 return TCL_ERROR; 506 } 507 CloseHandle (pi.hThread); 508 WaitForSingleObject (pi.hProcess, INFINITE); 509 GetExitCodeProcess (pi.hProcess, exitCode); 510 CloseHandle (pi.hProcess); 511 return TCL_OK; 512} 513 514/*----------------------------------------------------------------------------- 515 * TclX_OSlink -- 516 * 517 * System dependent interface to link functionality, which is not 518 * available on windows. 519 * 520 * Parameters: 521 * o interp - Errors returned in result. 522 * o srcPath - File to link. 523 * o targetPath - Path to new link. 524 * o funcName - Command or other name to use in not available error. 525 * Results: 526 * TCL_ERROR. 527 *----------------------------------------------------------------------------- 528 */ 529int 530TclX_OSlink (Tcl_Interp *interp, 531 char *srcPath, 532 char *targetPath, 533 char *funcName) 534{ 535 return TclXNotAvailableError (interp, funcName); 536} 537 538/*----------------------------------------------------------------------------- 539 * TclX_OSsymlink -- 540 * System dependent interface to symlink functionality. 541 * 542 * Parameters: 543 * o interp - Errors returned in result. 544 * o srcPath - Value of symbolic link. 545 * o targetPath - Path to new symbolic link. 546 * o funcName - Command or other name to use in not available error. 547 * Results: 548 * TCL_ERROR. 549 *----------------------------------------------------------------------------- 550 */ 551int 552TclX_OSsymlink (Tcl_Interp *interp, 553 char *srcPath, 554 char *targetPath, 555 char *funcName) 556{ 557 /* FIX: make an alias */ 558 return TclXNotAvailableError (interp, funcName); 559} 560 561/*----------------------------------------------------------------------------- 562 * TclXOSElapsedTime -- 563 * System dependent interface to get the elapsed CPU and real time. CPU time 564 * is not available under windows and zero is always returned. 565 * 566 * Parameters: 567 * o realTime - Elapsed real time, in milliseconds is returned here. 568 * o cpuTime - Elapsed CPU time, zero is always returned. 569 *----------------------------------------------------------------------------- 570 */ 571void 572TclXOSElapsedTime (clock_t *realTime, 573 clock_t *cpuTime) 574{ 575 static DWORD startTime = 0; 576 577 /* 578 * If this is the first call, get base time. 579 */ 580 if (startTime == 0) { 581 startTime = GetTickCount (); 582 } 583 *realTime = GetTickCount () - startTime; 584 *cpuTime = 0; 585} 586 587/*----------------------------------------------------------------------------- 588 * TclXOSkill -- 589 * System dependent interface to terminate a process. Apparently, 590 * it's not possible to send a specific signal in windows? 591 * 592 * Parameters: 593 * o interp - Errors returned in result. 594 * o pid - Process id, negative process group, etc. 595 * o signal - Signal to send. 596 * o funcName - Command or other name to use in not available error. 597 * Results: 598 * TCL_ERROR. 599 *----------------------------------------------------------------------------- 600 */ 601int 602TclXOSkill (Tcl_Interp *interp, 603 pid_t pid, 604 int signal, 605 char *funcName) 606{ 607 HANDLE processHandle; 608 609 processHandle = OpenProcess(PROCESS_TERMINATE, FALSE, (int) pid); 610 if (processHandle == NULL) { 611 Tcl_AppendResult(interp, "invalid pid", (char *) NULL); 612 return TCL_ERROR; 613 } 614 615 TerminateProcess(processHandle, 7); 616 CloseHandle(processHandle); 617 return TCL_OK; 618} 619 620/*----------------------------------------------------------------------------- 621 * TclXOSFstat -- 622 * System dependent interface to get status information on an open file. 623 * 624 * Parameters: 625 * o interp - Errors are returned in result. 626 * o channel - Channel to get file number for. 627 * o statBuf - Status information, made to look as much like Unix as 628 * possible. 629 * o ttyDev - If not NULL, a boolean indicating if the device is 630 * associated with a tty. (Always FALSE on windows). 631 * Results: 632 * TCL_OK or TCL_ERROR. 633 *----------------------------------------------------------------------------- 634 */ 635int 636TclXOSFstat (Tcl_Interp *interp, 637 Tcl_Channel channel, 638 struct stat *statBuf, 639 int *ttyDev) 640{ 641 HANDLE handle; 642 tclXwinFileType type; 643 FILETIME creation, access, modify; 644 645 /* FIX: More of this information is availiable from 646 * GetFileInformationByHandle 647 */ 648 649 handle = ChannelToHandle (channel, 0, &type); 650 651 if (handle == INVALID_HANDLE_VALUE) { 652 TclX_AppendObjResult (interp, "channel \"", 653 Tcl_GetChannelName (channel), 654 "\" has no device handle", (char *) NULL); 655 return TCL_ERROR; 656 } 657 658 /* 659 * These don't translate to windows. 660 */ 661 statBuf->st_dev = 0; 662 statBuf->st_ino = 0; 663 statBuf->st_rdev = 0; 664 665 statBuf->st_mode = 0; 666 switch (type) { 667 case TCLX_WIN_PIPE: 668 statBuf->st_mode |= S_IFIFO; 669 break; 670 case TCLX_WIN_FILE: 671 statBuf->st_mode |= S_IFREG; 672 break; 673 case TCLX_WIN_SOCKET: 674 statBuf->st_mode |= S_IFSOCK; 675 break; 676 case TCLX_WIN_CONSOLE: 677 statBuf->st_mode |= S_IFCHR; 678 break; 679 } 680 681 statBuf->st_nlink = (type == TCLX_WIN_FILE) ? 1 : 0; 682 statBuf->st_uid = 0; /* FIX??? */ 683 statBuf->st_gid = 0; 684 685 switch (type) { 686 case TCLX_WIN_FILE: 687 case TCLX_WIN_PIPE: 688 statBuf->st_size = GetFileSize (handle, NULL); 689 if (statBuf->st_size < 0) 690 goto winError; 691 692 if (!GetFileTime (handle, &creation, &access, &modify)) { 693 goto winError; 694 } 695 statBuf->st_atime = ConvertToUnixTime (creation); 696 statBuf->st_mtime = ConvertToUnixTime (access); 697 statBuf->st_ctime = ConvertToUnixTime (modify); 698 break; 699 700 case TCLX_WIN_SOCKET: 701 case TCLX_WIN_CONSOLE: 702 statBuf->st_size = 0; 703 statBuf->st_atime = 0; 704 statBuf->st_mtime = 0; 705 statBuf->st_ctime = 0; 706 break; 707 } 708 709 if (ttyDev != NULL) 710 *ttyDev = (type == TCLX_WIN_CONSOLE) ? 1 : 0; 711 return TCL_OK; 712 713 winError: 714 TclWinConvertError (GetLastError ()); 715 TclX_AppendObjResult (interp, Tcl_PosixError (interp), (char *) NULL); 716 return TCL_ERROR; 717 718} 719 720/*----------------------------------------------------------------------------- 721 * TclXOSWalkDir -- 722 * System dependent interface to reading the contents of a directory. The 723 * specified directory is walked and a callback is called on each entry. 724 * The "." and ".." entries are skipped. 725 * 726 * Parameters: 727 * o interp - Interp to return errors in. 728 * o path - Path to the directory. 729 * o hidden - Include hidden files. Ignored on Unix. 730 * o callback - Callback function to call on each directory entry. 731 * It should return TCL_OK to continue processing, TCL_ERROR if an 732 * error occured and TCL_BREAK to stop processing. The parameters are: 733 * o interp - Interp is passed though. 734 * o path - Normalized path to directory. 735 * o fileName - Tcl normalized file name in directory. 736 * o caseSensitive - Are the file names case sensitive? 737 * o clientData - Client data that was passed. 738 * o clientData - Client data to pass to callback. 739 * Results: 740 * TCL_OK if completed directory walk. TCL_BREAK if callback returned 741 * TCL_BREAK and TCL_ERROR if an error occured. 742 *----------------------------------------------------------------------------- 743 */ 744int 745TclXOSWalkDir (Tcl_Interp *interp, 746 char *path, 747 int hidden, 748 TclX_WalkDirProc *callback, 749 ClientData clientData) 750{ 751 char drivePattern[4] = "?:\\"; 752 char *p, *dir, *root, c; 753 int result = TCL_OK; 754 Tcl_DString pathBuf; 755 DWORD atts, volFlags; 756 HANDLE handle; 757 WIN32_FIND_DATA data; 758 BOOL found; 759 760 /* 761 * Convert the path to normalized form since some interfaces only 762 * accept backslashes. Also, ensure that the directory ends with a 763 * separator character. 764 */ 765 Tcl_DStringInit (&pathBuf); 766 Tcl_DStringAppend (&pathBuf, path, -1); 767 if (Tcl_DStringLength (&pathBuf) == 0) { 768 Tcl_DStringAppend (&pathBuf, ".", 1); 769 } 770 for (p = Tcl_DStringValue( &pathBuf); *p != '\0'; p++) { 771 if (*p == '/') { 772 *p = '\\'; 773 } 774 } 775 p--; 776 if (*p != '\\' && *p != ':') { 777 Tcl_DStringAppend(&pathBuf, "\\", 1); 778 } 779 dir = Tcl_DStringValue(&pathBuf); 780 781 /* 782 * First verify that the specified path is actually a directory. 783 */ 784 atts = GetFileAttributes (dir); 785 if ((atts == 0xFFFFFFFF) || ((atts & FILE_ATTRIBUTE_DIRECTORY) == 0)) { 786 Tcl_DStringFree (&pathBuf); 787 return TCL_OK; 788 } 789 790 /* 791 * Next check the volume information for the directory to see whether 792 * comparisons should be case sensitive or not. If the root is null, then 793 * we use the root of the current directory. If the root is just a drive 794 * specifier, we use the root directory of the given drive. 795 */ 796 switch (Tcl_GetPathType (dir)) { 797 case TCL_PATH_RELATIVE: 798 found = GetVolumeInformation (NULL, NULL, 0, NULL, 799 NULL, &volFlags, NULL, 0); 800 break; 801 case TCL_PATH_VOLUME_RELATIVE: 802 if (*dir == '\\') { 803 root = NULL; 804 } else { 805 root = drivePattern; 806 *root = *dir; 807 } 808 found = GetVolumeInformation (root, NULL, 0, NULL, 809 NULL, &volFlags, NULL, 0); 810 break; 811 case TCL_PATH_ABSOLUTE: 812 if (dir[1] == ':') { 813 root = drivePattern; 814 *root = *dir; 815 found = GetVolumeInformation (root, NULL, 0, NULL, 816 NULL, &volFlags, NULL, 0); 817 } else if (dir[1] == '\\') { 818 p = strchr(dir+2, '\\'); 819 p = strchr(p+1, '\\'); 820 p++; 821 c = *p; 822 *p = 0; 823 found = GetVolumeInformation (dir, NULL, 0, NULL, 824 NULL, &volFlags, NULL, 0); 825 *p = c; 826 } 827 break; 828 } 829 830 if (!found) { 831 Tcl_DStringFree (&pathBuf); 832 TclWinConvertError (GetLastError ()); 833 Tcl_ResetResult (interp); 834 TclX_AppendObjResult (interp, 835 "couldn't read volume information for \"", 836 path, "\": ", Tcl_PosixError (interp), 837 (char *) NULL); 838 return TCL_ERROR; 839 } 840 841 /* 842 * We need to check all files in the directory, so append a *.* 843 * to the path. 844 */ 845 dir = Tcl_DStringAppend (&pathBuf, "*.*", 3); 846 847 /* 848 * Now open the directory for reading and iterate over the contents. 849 */ 850 handle = FindFirstFile (dir, &data); 851 Tcl_DStringFree (&pathBuf); 852 853 if (handle == INVALID_HANDLE_VALUE) { 854 TclWinConvertError (GetLastError ()); 855 Tcl_ResetResult (interp); 856 TclX_AppendObjResult (interp, "couldn't read directory \"", 857 path, "\": ", Tcl_PosixError (interp), 858 (char *) NULL); 859 return TCL_ERROR; 860 } 861 862 /* 863 * Now iterate over all of the files in the directory. 864 */ 865 for (found = 1; found; found = FindNextFile (handle, &data)) { 866 /* 867 * Ignore hidden files if not requested. 868 */ 869 if ((data.dwFileAttributes & FILE_ATTRIBUTE_HIDDEN) && !hidden) 870 continue; 871 872 /* 873 * Skip "." and "..". 874 */ 875 if (STREQU (data.cFileName, ".") || STREQU (data.cFileName, "..")) 876 continue; 877 878 /* 879 * Call the callback with this file. 880 */ 881 result = (*callback) (interp, path, data.cFileName, 882 (volFlags & FS_CASE_SENSITIVE), clientData); 883 if (!((result == TCL_OK) || (result == TCL_CONTINUE))) 884 break; 885 } 886 887 Tcl_DStringFree (&pathBuf); 888 FindClose (handle); 889 return result; 890} 891 892/*----------------------------------------------------------------------------- 893 * TclXOSGetFileSize -- 894 * System dependent interface to get the size of an open file. 895 * 896 * Parameters: 897 * o channel - Channel. 898 * o fileSize - File size is returned here. 899 * Results: 900 * TCL_OK or TCL_ERROR. A POSIX error will be set. 901 *----------------------------------------------------------------------------- 902 */ 903int 904TclXOSGetFileSize (Tcl_Channel channel, 905 off_t *fileSize) 906{ 907 HANDLE handle; 908 tclXwinFileType type; 909 910 handle = ChannelToHandle (channel, 0, &type); 911 912 if (handle == INVALID_HANDLE_VALUE) { 913 return TCL_ERROR; 914 } 915 916 switch (type) { 917 case TCLX_WIN_PIPE: 918 case TCLX_WIN_FILE: 919 *fileSize = GetFileSize (handle, NULL); 920 if (*fileSize < 0) { 921 TclWinConvertError (GetLastError ()); 922 return TCL_ERROR; 923 } 924 break; 925 case TCLX_WIN_SOCKET: 926 case TCLX_WIN_CONSOLE: 927 *fileSize = 0; 928 } 929 return TCL_OK; 930} 931 932/*----------------------------------------------------------------------------- 933 * TclXOSftruncate -- 934 * System dependent interface to ftruncate functionality. 935 * 936 * Parameters: 937 * o interp - Error messages are returned in the interpreter. 938 * o channel - Channel to truncate. 939 * o newSize - Size to truncate the file to. 940 * o funcName - Command or other name to use in not available error. 941 * Returns: 942 * TCL_OK or TCL_ERROR. 943 *----------------------------------------------------------------------------- 944 */ 945int 946TclXOSftruncate (Tcl_Interp *interp, 947 Tcl_Channel channel, 948 off_t newSize, 949 char *funcName) 950{ 951 HANDLE handle; 952 int pos; 953 tclXwinFileType type; 954 955 handle = ChannelToHandle (channel, TCL_WRITABLE, &type); 956 957 if (handle == INVALID_HANDLE_VALUE) { 958 TclX_AppendObjResult (interp, "channel \"", 959 Tcl_GetChannelName (channel), 960 "\" was not open for write access", 961 (char *) NULL); 962 return TCL_ERROR; 963 } 964 if (type != TCLX_WIN_FILE) { 965 TclX_AppendObjResult (interp, "truncation of \"", 966 Tcl_GetChannelName (channel), 967 "\" failed: can only truncate disk files", 968 (char *) NULL); 969 return TCL_ERROR; 970 } 971 pos = (int) Tcl_Tell (channel); 972 if (SetFilePointer (handle, (LONG)newSize, NULL, 973 FILE_BEGIN) == 0xFFFFFFFF) { 974 TclWinConvertError (GetLastError ()); 975 TclX_AppendObjResult (interp, "truncation of \"", 976 Tcl_GetChannelName (channel), 977 "\" failed: ", Tcl_PosixError (interp), 978 (char *) NULL); 979 return TCL_ERROR; 980 } 981 /* 982 * FIX: we really ought to interpolate zeros when extending the file, 983 * since SetEndOfFile does not promise to do this. 984 */ 985 if (!SetEndOfFile (handle)) { 986 TclWinConvertError (GetLastError ()); 987 TclX_AppendObjResult (interp, "truncation of \"", 988 Tcl_GetChannelName (channel), 989 "\" failed: ", Tcl_PosixError (interp), 990 (char *) NULL); 991 if (pos >= 0) { 992 (void) SetFilePointer (handle, (LONG)pos, NULL, FILE_BEGIN); 993 } 994 return TCL_ERROR; 995 } 996 if (pos >= 0) { 997 if (SetFilePointer (handle, (LONG)pos, NULL, 998 FILE_BEGIN) == 0xFFFFFFFF) { 999 TclWinConvertError (GetLastError ()); 1000 TclX_AppendObjResult (interp, "couldn't restore position after ", 1001 "truncating \"", 1002 Tcl_GetChannelName (channel), 1003 "\": ", Tcl_PosixError (interp), 1004 (char *) NULL); 1005 return TCL_ERROR; 1006 } 1007 } 1008 return TCL_OK; 1009} 1010 1011/*----------------------------------------------------------------------------- 1012 * TclXOSfork -- 1013 * System dependent interface to fork functionality. Not supported on 1014 * windows. 1015 * 1016 * Parameters: 1017 * o interp - An error is returned in result. 1018 * o funcName - Command or other name to use in not available error. 1019 * Results: 1020 * TCL_OK or TCL_ERROR. 1021 *----------------------------------------------------------------------------- 1022 */ 1023int 1024TclXOSfork (Tcl_Interp *interp, 1025 Tcl_Obj *funcNameObj) 1026{ 1027 return TclXNotAvailableObjError (interp, funcNameObj); 1028} 1029 1030/*----------------------------------------------------------------------------- 1031 * TclXOSexecl -- 1032 * System dependent interface to execl functionality. On windows, this is 1033 * the equivlant of a fork and an execl, so a process id is returned. 1034 * 1035 * Parameters: 1036 * o interp - A process id or errors are returned in result. 1037 * o path - Path to the program. 1038 * o argList - NULL terminated argument vector. 1039 * Results: 1040 * TCL_ERROR or does not return. 1041 *----------------------------------------------------------------------------- 1042 */ 1043int 1044TclXOSexecl (Tcl_Interp *interp, 1045 char *path, 1046 char **argList) 1047{ 1048 int pid; 1049 char numBuf [32]; 1050 1051 pid = spawnvp (_P_NOWAIT , path, argList); 1052 if (pid == -1) { 1053 TclX_AppendObjResult (interp, "exec of \"", path, "\" failed: ", 1054 Tcl_PosixError (interp), (char *) NULL); 1055 return TCL_ERROR; 1056 } 1057 1058 sprintf (numBuf, "%d", pid); 1059 Tcl_SetResult (interp, numBuf, TCL_VOLATILE); 1060 return TCL_OK; 1061} 1062 1063/*----------------------------------------------------------------------------- 1064 * TclXOSInetAtoN -- 1065 * 1066 * Convert an internet address to an "struct in_addr" representation. 1067 * 1068 * Parameters: 1069 * o interp - If not NULL, an error message is return in the result. 1070 * If NULL, no error message is generated. 1071 * o strAddress - String address to convert. 1072 * o inAddress - Converted internet address is returned here. 1073 * Returns: 1074 * TCL_OK or TCL_ERROR. 1075 *----------------------------------------------------------------------------- 1076 */ 1077int 1078TclXOSInetAtoN (Tcl_Interp *interp, 1079 char *strAddress, 1080 struct in_addr *inAddress) 1081{ 1082 inAddress->s_addr = inet_addr (strAddress); 1083 if (inAddress->s_addr != INADDR_NONE) 1084 return TCL_OK; 1085 if (interp != NULL) { 1086 TclX_AppendObjResult (interp, "malformed address: \"", 1087 strAddress, "\"", (char *) NULL); 1088 } 1089 return TCL_ERROR; 1090} 1091 1092/*----------------------------------------------------------------------------- 1093 * TclXOSgetpeername -- 1094 * System dependent interface to getpeername functionality. 1095 * 1096 * Parameters: 1097 * o interp - Errors are returned in result. 1098 * o channel - Channel associated with the socket. 1099 * o sockaddr - Pointer to sockaddr structure. 1100 * o sockaddrSize - Size of the sockaddr struct. 1101 * Results: 1102 * TCL_OK or TCL_ERROR, sets a posix error. 1103 *----------------------------------------------------------------------------- 1104 */ 1105int 1106TclXOSgetpeername (Tcl_Interp *interp, 1107 Tcl_Channel channel, 1108 void *sockaddr, 1109 int sockaddrSize) 1110{ 1111 SOCKET sock; 1112 1113 sock = ChannelToSocket (interp, channel); 1114 if (sock == INVALID_SOCKET) 1115 return TCL_ERROR; 1116 if (getpeername (sock, (struct sockaddr *) sockaddr, &sockaddrSize) < 0) { 1117 TclX_AppendObjResult (interp, Tcl_GetChannelName (channel), ": ", 1118 Tcl_PosixError (interp), (char *) NULL); 1119 return TCL_ERROR; 1120 } 1121 return TCL_OK; 1122} 1123 1124/*----------------------------------------------------------------------------- 1125 * TclXOSgetsockname -- 1126 * System dependent interface to getsockname functionality. 1127 * 1128 * Parameters: 1129 * o interp - Errors are returned in result. 1130 * o channel - Channel associated with the socket. 1131 * o sockaddr - Pointer to sockaddr structure. 1132 * o sockaddrSize - Size of the sockaddr struct. 1133 * Results: 1134 * TCL_OK or TCL_ERROR, sets a posix error. 1135 *----------------------------------------------------------------------------- 1136 */ 1137int 1138TclXOSgetsockname (Tcl_Interp *interp, 1139 Tcl_Channel channel, 1140 void *sockaddr, 1141 int sockaddrSize) 1142{ 1143 SOCKET sock; 1144 1145 sock = ChannelToSocket (interp, channel); 1146 if (sock == INVALID_SOCKET) 1147 return TCL_ERROR; 1148 1149 if (getsockname (sock, (struct sockaddr *) sockaddr, &sockaddrSize) < 0) { 1150 TclX_AppendObjResult (interp, Tcl_GetChannelName (channel), ": ", 1151 Tcl_PosixError (interp), (char *) NULL); 1152 return TCL_ERROR; 1153 } 1154 return TCL_OK; 1155} 1156 1157/*----------------------------------------------------------------------------- 1158 * TclXOSgetsockopt -- 1159 * Get the value of a integer socket option. 1160 * 1161 * Parameters: 1162 * o interp - Errors are returned in the result. 1163 * o channel - Channel associated with the socket. 1164 * o option - Socket option to get. 1165 * o valuePtr - Integer value is returned here. 1166 * Returns: 1167 * TCL_OK or TCL_ERROR. 1168 *----------------------------------------------------------------------------- 1169 */ 1170int 1171TclXOSgetsockopt (interp, channel, option, valuePtr) 1172 Tcl_Interp *interp; 1173 Tcl_Channel channel; 1174 int option; 1175 int *valuePtr; 1176{ 1177 int valueLen = sizeof (*valuePtr); 1178 SOCKET sock; 1179 1180 sock = ChannelToSocket (interp, channel); 1181 if (sock == INVALID_SOCKET) 1182 return TCL_ERROR; 1183 1184 if (getsockopt (sock, SOL_SOCKET, option, 1185 (void*) valuePtr, &valueLen) != 0) { 1186 TclX_AppendObjResult (interp, Tcl_GetChannelName (channel), ": ", 1187 Tcl_PosixError (interp), (char *) NULL); 1188 return TCL_ERROR; 1189 } 1190 return TCL_OK; 1191} 1192 1193/*----------------------------------------------------------------------------- 1194 * TclXOSsetsockopt -- 1195 * Set the value of a integer socket option. 1196 * 1197 * Parameters: 1198 * o interp - Errors are returned in the result. 1199 * o channel - Channel associated with the socket. 1200 * o option - Socket option to get. 1201 * o value - Valid integer value for the option. 1202 * Returns: 1203 * TCL_OK or TCL_ERROR. 1204 *----------------------------------------------------------------------------- 1205 */ 1206int 1207TclXOSsetsockopt (interp, channel, option, value) 1208 Tcl_Interp *interp; 1209 Tcl_Channel channel; 1210 int option; 1211 int value; 1212{ 1213 int valueLen = sizeof (value); 1214 SOCKET sock; 1215 1216 sock = ChannelToSocket (interp, channel); 1217 if (sock == INVALID_SOCKET) 1218 return TCL_ERROR; 1219 1220 if (setsockopt (sock, SOL_SOCKET, option, 1221 (void*) &value, valueLen) != 0) { 1222 TclX_AppendObjResult (interp, Tcl_GetChannelName (channel), ": ", 1223 Tcl_PosixError (interp), (char *) NULL); 1224 return TCL_ERROR; 1225 } 1226 return TCL_OK; 1227} 1228 1229/*----------------------------------------------------------------------------- 1230 * TclXOSchmod -- 1231 * System dependent interface to chmod functionality. 1232 * 1233 * Parameters: 1234 * o interp - Errors returned in result. 1235 * o fileName - Name of to set the mode on. 1236 * o mode - New, unix style file access mode. 1237 * Results: 1238 * TCL_OK or TCL_ERROR. 1239 *----------------------------------------------------------------------------- 1240 */ 1241int 1242TclXOSchmod (interp, fileName, mode) 1243 Tcl_Interp *interp; 1244 char *fileName; 1245 int mode; 1246{ 1247#if 0 1248 /*FIX:*/ 1249 if (chmod (fileName, (unsigned short) mode) < 0) { 1250 TclX_AppendObjResult (interp, "chmod failed on \"", fileName, "\": ", 1251 Tcl_PosixError (interp), (char *) NULL); 1252 return TCL_ERROR; 1253 } 1254 return TCL_OK; 1255#else 1256 TclX_AppendObjResult (interp, "chmod is not available on this system", 1257 (char *) NULL); 1258 return TCL_ERROR; 1259#endif 1260} 1261 1262/*----------------------------------------------------------------------------- 1263 * TclXOSfchmod -- 1264 * System dependent interface to fchmod functionality. 1265 * 1266 * Parameters: 1267 * o interp - Errors returned in result. 1268 * o channel - Channel to set the mode on. 1269 * o mode - New, unix style file access mode. 1270 * o funcName - Command or other string to use in not available error. 1271 * Results: 1272 * TCL_OK or TCL_ERROR. 1273 *----------------------------------------------------------------------------- 1274 */ 1275int 1276TclXOSfchmod (interp, channel, mode, funcName) 1277 Tcl_Interp *interp; 1278 Tcl_Channel channel; 1279 int mode; 1280 char *funcName; 1281{ 1282#if 0 1283 FIX: 1284 if (fchmod (ChannelToFnum (channel, 0), (unsigned short) mode) < 0) { 1285 TclX_AppendObjResult (interp, Tcl_PosixError (interp), (char *) NULL); 1286 return TCL_ERROR; 1287 } 1288#else 1289 TclX_AppendObjResult (interp, funcName, " is not available on this system", 1290 (char *) NULL); 1291 return TCL_ERROR; 1292#endif 1293} 1294 1295/*----------------------------------------------------------------------------- 1296 * TclXOSChangeOwnGrp -- 1297 * Change the owner and/or group of a file by file name. 1298 * 1299 * Parameters: 1300 * o interp - Pointer to the current interpreter, error messages will be 1301 * returned in the result. 1302 * o options - Option flags are: 1303 * o TCLX_CHOWN - Change file's owner. 1304 * o TCLX_CHGRP - Change file's group. 1305 * o ownerStr - String containing owner name or id. NULL if TCLX_CHOWN 1306 * not specified. 1307 * o groupStr - String containing owner name or id. NULL if TCLX_CHOWN 1308 * not specified. If NULL and TCLX_CHOWN is specified, the user's group 1309 * is used. 1310 * o files - NULL terminated list of file names. 1311 * o funcName - Command or other name to use in not available error. 1312 * Returns: 1313 * TCL_OK or TCL_ERROR. 1314 *----------------------------------------------------------------------------- 1315 */ 1316 1317int 1318TclXOSChangeOwnGrpObj (interp, options, ownerStr, groupStr, files, funcName) 1319 Tcl_Interp *interp; 1320 unsigned options; 1321 char *ownerStr; 1322 char *groupStr; 1323 Tcl_Obj *files; 1324 char *funcName; 1325{ 1326 return TclXNotAvailableError (interp, funcName); 1327} 1328 1329/*----------------------------------------------------------------------------- 1330 * TclXOSFChangeOwnGrp -- 1331 * Change the owner and/or group of a file by open channel. 1332 * 1333 * Parameters: 1334 * o interp - Pointer to the current interpreter, error messages will be 1335 * returned in the result. 1336 * o options - Option flags are: 1337 * o TCLX_CHOWN - Change file's owner. 1338 * o TCLX_CHGRP - Change file's group. 1339 * o ownerStr - String containing owner name or id. NULL if TCLX_CHOWN 1340 * not specified. 1341 * o groupStr - String containing owner name or id. NULL if TCLX_CHOWN 1342 * not specified. If NULL and TCLX_CHOWN is specified, the user's group 1343 * is used. 1344 * o channelIds - NULL terminated list of channel ids. 1345 * o funcName - Command or other name to use in not available error. 1346 * Returns: 1347 * TCL_OK or TCL_ERROR. 1348 *----------------------------------------------------------------------------- 1349 */ 1350int 1351TclXOSFChangeOwnGrpObj (interp, options, ownerStr, groupStr, channelIds, funcName) 1352 Tcl_Interp *interp; 1353 unsigned options; 1354 char *ownerStr; 1355 char *groupStr; 1356 Tcl_Obj *channelIds; 1357 char *funcName; 1358{ 1359 return TclXNotAvailableError (interp, funcName); 1360} 1361 1362/*----------------------------------------------------------------------------- 1363 * TclXOSGetSelectFnum -- 1364 * Convert a channel its read and write file numbers for use in select. 1365 * 1366 * Parameters: 1367 * o interp - Pointer to the current interpreter, error messages will be 1368 * returned in the result. 1369 * o channel - Channel to get the numbers for. 1370 * o direction - TCL_READABLE or TCL_WRITABLE. 1371 * o fnumPtr - The file number for the direction is returned here. 1372 * Returns: 1373 * TCL_OK or TCL_ERROR. 1374 *----------------------------------------------------------------------------- 1375 */ 1376int 1377TclXOSGetSelectFnum (Tcl_Interp *interp, 1378 Tcl_Channel channel, 1379 int direction, 1380 int *fnumPtr) 1381{ 1382 tclXwinFileType type; 1383 HANDLE handle = ChannelToHandle (channel, direction, &type); 1384 1385 if (handle == INVALID_HANDLE_VALUE) { 1386 TclX_AppendObjResult (interp, "channel \"", 1387 Tcl_GetChannelName (channel), 1388 "\" was not open for requested access", 1389 (char *) NULL); 1390 return TCL_ERROR; 1391 } 1392 1393 if (type != TCLX_WIN_SOCKET) { 1394 TclX_AppendObjResult (interp, "channel \"", 1395 Tcl_GetChannelName (channel), 1396 "\" is not a socket; select only works on ", 1397 "sockets on Windows", (char *) NULL); 1398 return TCL_ERROR; 1399 } 1400 1401 *fnumPtr = (int) handle; 1402 return TCL_OK; 1403} 1404 1405/*----------------------------------------------------------------------------- 1406 * TclXOSHaveFlock -- 1407 * System dependent interface to determine if file locking is available. 1408 * Returns: 1409 * TRUE if file locking is available, FALSE if it is not. 1410 *----------------------------------------------------------------------------- 1411 */ 1412int 1413TclXOSHaveFlock () 1414{ 1415 OVERLAPPED start; 1416 1417 start.Internal = 0; 1418 start.InternalHigh = 0; 1419 start.Offset = 0; 1420 start.OffsetHigh = 0; 1421 start.hEvent = 0; 1422 1423 if (!LockFileEx (NULL, 0, 0, 0, 0, &start)) { 1424 if (GetLastError () == ERROR_CALL_NOT_IMPLEMENTED) 1425 return FALSE; 1426 } 1427 return TRUE; 1428} 1429 1430/*----------------------------------------------------------------------------- 1431 * LockUnlockSetup -- 1432 * 1433 * Do common setup work for locking or unlocking a file. 1434 * 1435 * Parameters: 1436 * o interp - Errors are return in the result. 1437 * o lockInfoPtr - Lock specification. 1438 * o startPtr - Start of area to lock is returned in struct. 1439 * o lengthLowPtr - Low-order 32 bits of length of the file to lock. 1440 * o lengthHighPtr - High-order 32 bits of length of the file to lock. Files 1441 * of length greater than 32 bits are not support. This is only to allow 1442 * for locking the entier range of the file 1443 * o whichMsg - Either "lock" or "unlock", for error messages. 1444 * Returns: 1445 * The file handle or NULL if an error occurs. 1446 *----------------------------------------------------------------------------- 1447 */ 1448static HANDLE 1449LockUnlockSetup (Tcl_Interp *interp, 1450 TclX_FlockInfo *lockInfoPtr, 1451 LPOVERLAPPED startPtr, 1452 LPDWORD lengthLowPtr, 1453 LPDWORD lengthHighPtr, 1454 char *whichMsg) 1455{ 1456 HANDLE handle; 1457 tclXwinFileType type; 1458 1459 /* 1460 * Get the handle and validate that this is something we can lock. 1461 */ 1462 handle = ChannelToHandle (lockInfoPtr->channel, 0, &type); 1463 1464 if (handle == INVALID_HANDLE_VALUE) { 1465 TclX_AppendObjResult (interp, "channel \"", 1466 Tcl_GetChannelName (lockInfoPtr->channel), 1467 "\" has no device handle", (char *) NULL); 1468 return handle; 1469 } 1470 1471 switch (type) { 1472 case TCLX_WIN_PIPE: 1473 TclX_AppendObjResult (interp, 1474 "can't lock a pipe line under MS Windows", 1475 (char *) NULL); 1476 return INVALID_HANDLE_VALUE; 1477 case TCLX_WIN_FILE: 1478 break; 1479 case TCLX_WIN_SOCKET: 1480 TclX_AppendObjResult (interp, "can't lock a socket under windows", 1481 (char *) NULL); 1482 return INVALID_HANDLE_VALUE; 1483 case TCLX_WIN_CONSOLE: 1484 break; /* FIX: Is this legal?? */ 1485 default: 1486 panic ("unknown win channel type %d\n", type); 1487 } 1488 1489 /* 1490 * Calculate actual offset of the start. 1491 */ 1492 switch (lockInfoPtr->whence) { 1493 case 0: /* start */ 1494 startPtr->Offset = lockInfoPtr->start; 1495 break; 1496 case 1: /* current */ 1497 startPtr->Offset = SetFilePointer (handle, 0, NULL, FILE_CURRENT); 1498 if (startPtr->Offset == 0xFFFFFFFF) 1499 goto winError; 1500 startPtr->Offset += lockInfoPtr->start; 1501 break; 1502 case 2: /* end */ 1503 startPtr->Offset = GetFileSize (handle, NULL); 1504 if (startPtr->Offset < 0) 1505 goto winError; 1506 startPtr->Offset += lockInfoPtr->start; 1507 break; 1508 } 1509 startPtr->Internal = 0; 1510 startPtr->InternalHigh = 0; 1511 startPtr->OffsetHigh = 0; 1512 startPtr->hEvent = 0; 1513 1514 /* 1515 * Determine length of lock. If zero, the remained of the file is locked 1516 * out its maximum length. 1517 */ 1518 *lengthHighPtr = 0; 1519 if (lockInfoPtr->len == 0) { 1520 *lengthHighPtr = 0x7FFFFFFF; 1521 *lengthLowPtr = 0xFFFFFFFF; 1522 } else { 1523 *lengthLowPtr = lockInfoPtr->len; 1524 } 1525 return handle; 1526 1527 winError: 1528 TclWinConvertError (GetLastError ()); 1529 lockInfoPtr->gotLock = FALSE; 1530 TclX_AppendObjResult (interp, whichMsg, " of \"", 1531 Tcl_GetChannelName (lockInfoPtr->channel), 1532 "\" failed: ", Tcl_PosixError (interp), 1533 (char *) NULL); 1534 return INVALID_HANDLE_VALUE; 1535} 1536 1537/*----------------------------------------------------------------------------- 1538 * TclXOSFlock -- 1539 * System dependent interface to locking a file. 1540 * 1541 * Parameters: 1542 * o interp - Pointer to the current interpreter, error messages will be 1543 * returned in the result. 1544 * o lockInfoPtr - Lock specification, gotLock will be initialized. 1545 * Returns: 1546 * TCL_OK or TCL_ERROR. 1547 *----------------------------------------------------------------------------- 1548 */ 1549int 1550TclXOSFlock (interp, lockInfoPtr) 1551 Tcl_Interp *interp; 1552 TclX_FlockInfo *lockInfoPtr; 1553{ 1554 HANDLE handle; 1555 DWORD flags, lengthHigh, lengthLow; 1556 OVERLAPPED start; 1557 1558 handle = LockUnlockSetup (interp, 1559 lockInfoPtr, 1560 &start, 1561 &lengthLow, 1562 &lengthHigh, 1563 "lock"); 1564 1565 if (handle == INVALID_HANDLE_VALUE) 1566 return TCL_ERROR; 1567 1568 flags = 0; 1569 if (lockInfoPtr->access == TCL_WRITABLE) 1570 flags |= LOCKFILE_EXCLUSIVE_LOCK; 1571 if (!lockInfoPtr->block) 1572 flags |= LOCKFILE_FAIL_IMMEDIATELY; 1573 1574 if (!LockFileEx (handle, flags, 0, lengthLow, lengthHigh, &start)) { 1575 if (GetLastError () == ERROR_LOCK_VIOLATION) { 1576 lockInfoPtr->gotLock = FALSE; 1577 return TCL_OK; 1578 } 1579 goto winError; 1580 } 1581 lockInfoPtr->gotLock = TRUE; 1582 return TCL_OK; 1583 1584 winError: 1585 if (GetLastError () == ERROR_CALL_NOT_IMPLEMENTED) { 1586 TclX_AppendObjResult (interp, "file locking is not yet available on ", 1587 "Windows 3.1 and 95", (char *) NULL); 1588 } else { 1589 TclWinConvertError (GetLastError ()); 1590 TclX_AppendObjResult (interp, "lock of \"", 1591 Tcl_GetChannelName (lockInfoPtr->channel), 1592 "\" failed: ", Tcl_PosixError (interp), 1593 (char *) NULL); 1594 } 1595 lockInfoPtr->gotLock = FALSE; 1596 return TCL_ERROR; 1597} 1598 1599/*----------------------------------------------------------------------------- 1600 * TclXOSFunlock -- 1601 * System dependent interface to unlocking a file. 1602 * 1603 * Parameters: 1604 * o interp - Pointer to the current interpreter, error messages will be 1605 * returned in the result. 1606 * o lockInfoPtr - Lock specification. 1607 * Returns: 1608 * TCL_OK or TCL_ERROR. 1609 *----------------------------------------------------------------------------- 1610 */ 1611int 1612TclXOSFunlock (interp, lockInfoPtr) 1613 Tcl_Interp *interp; 1614 TclX_FlockInfo *lockInfoPtr; 1615{ 1616 HANDLE handle; 1617 DWORD lengthHigh, lengthLow; 1618 OVERLAPPED start; 1619 1620 handle = LockUnlockSetup (interp, 1621 lockInfoPtr, 1622 &start, 1623 &lengthLow, 1624 &lengthHigh, 1625 "unlock"); 1626 if (handle == INVALID_HANDLE_VALUE) 1627 return TCL_ERROR; 1628 1629 if (!UnlockFileEx (handle, 0, lengthLow, lengthHigh, &start)) { 1630 goto winError; 1631 } 1632 return TCL_OK; 1633 1634 winError: 1635 if (GetLastError () == ERROR_CALL_NOT_IMPLEMENTED) { 1636 TclX_AppendObjResult (interp, "file locking is not yet available on ", 1637 "Windows 3.1 and 95", (char *) NULL); 1638 } else { 1639 TclWinConvertError (GetLastError ()); 1640 TclX_AppendObjResult (interp, "unlock of \"", 1641 Tcl_GetChannelName (lockInfoPtr->channel), 1642 "\" failed: ", Tcl_PosixError (interp), 1643 (char *) NULL); 1644 } 1645 return TCL_ERROR; 1646} 1647 1648/*----------------------------------------------------------------------------- 1649 * TclXOSGetAppend -- 1650 * System dependent interface determine if a channel is in force append mode. 1651 * 1652 * Parameters: 1653 * o interp - Pointer to the current interpreter, error messages will be 1654 * returned in the result. 1655 * o channel - Channel to get mode for. The write file is used. 1656 * o valuePtr - TRUE is returned if in append mode, FALSE if not. 1657 * Returns: 1658 * TCL_OK or TCL_ERROR. 1659 *----------------------------------------------------------------------------- 1660 */ 1661int 1662TclXOSGetAppend (interp, channel, valuePtr) 1663 Tcl_Interp *interp; 1664 Tcl_Channel channel; 1665 int *valuePtr; 1666{ 1667 return TclXNotAvailableError (interp, 1668 "append mode"); 1669} 1670 1671/*----------------------------------------------------------------------------- 1672 * TclXOSSetAppend -- 1673 * System dependent interface set force append mode on a channel. 1674 * 1675 * Parameters: 1676 * o interp - Pointer to the current interpreter, error messages will be 1677 * returned in the result. 1678 * o channel - Channel to get mode for. The write file is used. 1679 * o value - TRUE to enable, FALSE to disable. 1680 * Returns: 1681 * TCL_OK or TCL_ERROR. 1682 *----------------------------------------------------------------------------- 1683 */ 1684int 1685TclXOSSetAppend (interp, channel, value) 1686 Tcl_Interp *interp; 1687 Tcl_Channel channel; 1688 int value; 1689{ 1690 return TclXNotAvailableError (interp, 1691 "append mode"); 1692} 1693 1694/*----------------------------------------------------------------------------- 1695 * TclXOSGetCloseOnExec -- 1696 * System dependent interface determine if a channel has close-on-exec set. 1697 * 1698 * Parameters: 1699 * o interp - Pointer to the current interpreter, error messages will be 1700 * returned in the result. 1701 * o channel - Channel to get mode for. The write file is used. 1702 * o valuePtr - TRUE is close-on-exec, FALSE if not. 1703 * Returns: 1704 * TCL_OK or TCL_ERROR. 1705 *----------------------------------------------------------------------------- 1706 */ 1707int 1708TclXOSGetCloseOnExec (interp, channel, valuePtr) 1709 Tcl_Interp *interp; 1710 Tcl_Channel channel; 1711 int *valuePtr; 1712{ 1713 HANDLE handle; 1714 tclXwinFileType type; 1715 DWORD flags; 1716 1717 handle = ChannelToHandle (channel, 0, &type); 1718 1719 if (handle == INVALID_HANDLE_VALUE) { 1720 TclX_AppendObjResult (interp, "channel \"", 1721 Tcl_GetChannelName (channel), 1722 "\" has no device handle", (char *) NULL); 1723 return TCL_ERROR; 1724 } 1725 1726 /* 1727 * The following works on Windows NT, but not on Windows 95. 1728 */ 1729 if (!GetHandleInformation (handle, &flags)) { 1730 TclWinConvertError (GetLastError ()); 1731 TclX_AppendObjResult (interp, "getting close-on-exec for \"", 1732 Tcl_GetChannelName (channel), 1733 "\" failed: ", Tcl_PosixError (interp), 1734 (char *) NULL); 1735 return TCL_ERROR; 1736 } 1737 1738 /* 1739 * N.B. The value of the CLOEXEC flag is the inverse of HANDLE_FLAG_INHERIT. 1740 */ 1741 *valuePtr = (flags & HANDLE_FLAG_INHERIT) ? 0 : 1; 1742 return TCL_OK; 1743} 1744 1745/*----------------------------------------------------------------------------- 1746 * TclXOSSetCloseOnExec -- 1747 * System dependent interface set close-on-exec on a channel. 1748 * 1749 * Parameters: 1750 * o interp - Pointer to the current interpreter, error messages will be 1751 * returned in the result. 1752 * o channel - Channel to get mode for. The write file is used. 1753 * o value - TRUE to enable, FALSE to disable. 1754 * Returns: 1755 * TCL_OK or TCL_ERROR. 1756 *----------------------------------------------------------------------------- 1757 */ 1758int 1759TclXOSSetCloseOnExec (interp, channel, value) 1760 Tcl_Interp *interp; 1761 Tcl_Channel channel; 1762 int value; 1763{ 1764 HANDLE handle; 1765 tclXwinFileType type; 1766 1767 handle = ChannelToHandle (channel, 0, &type); 1768 1769 if (handle == INVALID_HANDLE_VALUE) { 1770 TclX_AppendObjResult (interp, "channel \"", 1771 Tcl_GetChannelName (channel), 1772 "\" has no device handle", (char *) NULL); 1773 return TCL_ERROR; 1774 } 1775 1776 /* 1777 * The following works on Windows NT, but not on Windows 95. 1778 * N.B. The value of the CLOEXEC flag is the inverse of HANDLE_FLAG_INHERIT. 1779 */ 1780 if (!SetHandleInformation (handle, 1781 HANDLE_FLAG_INHERIT, 1782 value ? 0 : HANDLE_FLAG_INHERIT)) { 1783 TclWinConvertError (GetLastError ()); 1784 TclX_AppendObjResult (interp, "setting close-on-exec for \"", 1785 Tcl_GetChannelName (channel), 1786 "\" failed: ", Tcl_PosixError (interp), 1787 (char *) NULL); 1788 return TCL_ERROR; 1789 } 1790 return TCL_OK; 1791} 1792 1793 1794