summaryrefslogtreecommitdiffstats
path: root/test/istore.c
blob: f9e19d0dabefd5f3bd444c8a911b2225818e273f (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 * Copyright by the Board of Trustees of the University of Illinois.         *
 * All rights reserved.                                                      *
 *                                                                           *
 * This file is part of HDF5.  The full HDF5 copyright notice, including     *
 * terms governing use, modification, and redistribution, is contained in    *
 * the files COPYING and Copyright.html.  COPYING can be found at the root   *
 * of the source code distribution tree; Copyright.html can be found at the  *
 * root level of an installed copy of the electronic HDF5 document set and   *
 * is linked from the top-level documents page.  It can also be found at     *
 * http://hdf.ncsa.uiuc.edu/HDF5/doc/Copyright.html.  If you do not have     *
 * access to either file, you may request a copy from hdfhelp@ncsa.uiuc.edu. *
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

/* Programmer:	Robb Matzke <matzke@llnl.gov>
 *		Wednesday, October 15, 1997
 *
 * Purpose:	Tests various aspects of indexed raw data storage.
 */

#define H5F_PACKAGE		/*suppress error about including H5Fpkg	  */

#include "h5test.h"
#include "H5private.h"
#include "H5Dprivate.h"
#include "H5Eprivate.h"
#include "H5Iprivate.h"
#include "H5Pprivate.h"
#include "H5Fpkg.h"
#include "H5Gprivate.h"
#include "H5Oprivate.h"
#include "H5Pprivate.h"
#include "H5Vprivate.h"

const char *FILENAME[] = {
    "istore",
    NULL
};


#define TEST_SMALL	0x0001
#define TEST_MEDIUM	0x0002
#define TEST_LARGE	0x0004

/* The datatype of the dataset operated on by this test */
#define TEST_DATATYPE   H5T_NATIVE_UCHAR

#define TEST_CHUNK_SIZE 50
#ifdef H5_HAVE_LARGE_HSIZET
#define TEST_SPARSE_SIZE 1000000
#else /* H5_HAVE_LARGE_HSIZET */
#define TEST_SPARSE_SIZE 1200
#endif /* H5_HAVE_LARGE_HSIZET */

hsize_t chunk_dims[H5O_LAYOUT_NDIMS];
hsize_t zero[H5O_LAYOUT_NDIMS];


/*-------------------------------------------------------------------------
 * Function:	print_array
 *
 * Purpose:	Prints the values in an array
 *
 * Return:	void
 *
 * Programmer:	Robb Matzke
 *		Friday, October 10, 1997
 *
 * Modifications:
 *
 *-------------------------------------------------------------------------
 */
static void
print_array(uint8_t *array, size_t nx, size_t ny, size_t nz)
{
    size_t	i, j, k;

    for (i = 0; i < nx; i++) {
	if (nz > 1) {
	    fprintf(stderr,"i=%lu:\n", (unsigned long)i);
	} else {
	    fprintf(stderr,"%03lu:", (unsigned long)i);
	}

	for (j = 0; j < ny; j++) {
	    if (nz > 1)
		fprintf(stderr,"%03lu:", (unsigned long)j);
	    for (k = 0; k < nz; k++) {
		fprintf(stderr," %3d", *array++);
	    }
	    if (nz > 1)
		fprintf(stderr,"\n");
	}
	fprintf(stderr,"\n");
    }
}


/*-------------------------------------------------------------------------
 * Function:	new_object
 *
 * Purpose:	Creates a new object that refers to a indexed storage of raw
 *		data.  No raw data is stored.
 *
 * Return:	Success:	ID of dataset
 *
 *		Failure:	-1
 *
 * Programmer:	Robb Matzke
 *		Wednesday, October 15, 1997
 *
 * Modifications:
 *              Converted to use datasets instead of directly messing with
 *              the istore routines, etc. since the new raw data architecture
 *              performs hyperslab operations at a higher level than the
 *              istore routines did and the new istore routines can't handle
 *              I/O on more than one chunk at a time. QAK - 2003/04/16
 *
 *-------------------------------------------------------------------------
 */
static hid_t
new_object(hid_t f, const char *name, int ndims, hsize_t dims[], hsize_t cdims[])
{
    hid_t dataset;      /* Dataset ID */
    hid_t space;        /* Dataspace ID */
    hid_t dcpl;         /* Dataset creation property list ID */

    /* Create the dataset creation property list */
    if ((dcpl=H5Pcreate(H5P_DATASET_CREATE))<0) TEST_ERROR;

    /* Set the chunk dimensions */
    if(H5Pset_chunk(dcpl, ndims, cdims) < 0) TEST_ERROR;

    /* Create the dataspace */
    if((space = H5Screate_simple(ndims, dims, NULL))<0) TEST_ERROR;

    /* Create the dataset */
    if((dataset = H5Dcreate (f, name, TEST_DATATYPE, space, dcpl))<0) TEST_ERROR;

    /* Clean up */

    /* Close property lists */
    if(H5Pclose(dcpl)<0) TEST_ERROR;

    /* Close dataspace */
    if(H5Sclose(space)<0) TEST_ERROR;

    return dataset;

error:
    return -1;
}


/*-------------------------------------------------------------------------
 * Function:	test_create
 *
 * Purpose:	Creates a named object that refers to indexed storage of raw
 *		data.  No raw data is stored.
 *
 * Return:	Success:	SUCCEED
 *
 *		Failure:	FAIL
 *
 * Programmer:	Robb Matzke
 *		Wednesday, October 15, 1997
 *
 * Modifications:
 *
 *-------------------------------------------------------------------------
 */
static herr_t
test_create(hid_t f, const char *prefix)
{
    hid_t       dataset;        /* Dataset ID */
    hsize_t     dims[H5O_LAYOUT_NDIMS+1]; /* Dimensions of dataset */
    char        name[256];      /* Dataset name */
    unsigned    u;              /* Local index variable */

    TESTING("istore create");

    dims[0]=TEST_CHUNK_SIZE;
    for (u = 1; u <= H5S_MAX_RANK; u++) {
        /* Initialize the dimension size in this new dimension */
        dims[u]=TEST_CHUNK_SIZE;

        /* Create chunked dataset of this dimensionality */
	HDsnprintf(name, sizeof name, "%s_%02u", prefix, u);
	if ((dataset=new_object(f, name, (int)u, dims, chunk_dims)) < 0)
	    return FAIL;

        /* Close dataset created */
        if(H5Dclose(dataset)<0)
            return FAIL;
    }

    PASSED();
    return SUCCEED;
}


/*-------------------------------------------------------------------------
 * Function:	test_extend
 *
 * Purpose:	Creates an empty object and then writes to it in such a way
 *		as to always extend the object's domain without creating
 *		holes and without causing the object to become concave.
 *
 * Return:	Success:	SUCCEED
 *
 *		Failure:	FAIL
 *
 * Programmer:	Robb Matzke
 *		Wednesday, October 15, 1997
 *
 * Modifications:
 *
 *-------------------------------------------------------------------------
 */
static herr_t
test_extend(hid_t f, const char *prefix,
	    size_t nx, size_t ny, size_t nz)
{
    hid_t               dataset;        /* Dataset ID */
    hid_t               fspace;         /* Dataset's file dataspace */
    hid_t               mspace;         /* Dataset's memory dataspace */
    hsize_t		i, j, k, ctr;
    int			ndims;
    uint8_t		*buf = NULL, *check = NULL, *whole = NULL;
    char		dims[64], s[256], name[256];
    hsize_t		offset[3];
    hsize_t		max_corner[3];
    hsize_t		size[3];
    hsize_t		whole_size[3];
    hsize_t		nelmts;

    if (!nz) {
	if (!ny) {
	    ndims = 1;
	    ny = nz = 1;
	    sprintf(dims, "%lu", (unsigned long) nx);
	} else {
	    ndims = 2;
	    nz = 1;
	    sprintf(dims, "%lux%lu", (unsigned long) nx, (unsigned long) ny);
	}
    } else {
	ndims = 3;
	sprintf(dims, "%lux%lux%lu",
		(unsigned long) nx, (unsigned long) ny, (unsigned long) nz);
    }

    sprintf(s, "istore extend: %s", dims);
    TESTING(s);
    buf = HDmalloc(nx * ny * nz);
    check = HDmalloc(nx * ny * nz);
    whole = HDcalloc(1,nx*ny*nz);

    whole_size[0] = nx;
    whole_size[1] = ny;
    whole_size[2] = nz;
    max_corner[0] = 0;
    max_corner[1] = 0;
    max_corner[2] = 0;

    /* Build the new empty object */
    sprintf(name, "%s_%s", prefix, dims);
    if ((dataset=new_object(f, name, ndims, whole_size, whole_size)) < 0) {
	fprintf(stderr,"    Cannot create %u-d object `%s'\n", ndims, name);
	goto error;
    }

    /* Get dataset's dataspace */
    if((fspace=H5Dget_space(dataset))<0) TEST_ERROR;

    for (ctr = 0;
	 H5V_vector_lt_u((unsigned)ndims, max_corner, whole_size);
	 ctr++) {

	/* Size and location */
	if (0 == ctr) {
	    offset[0] = offset[1] = offset[2] = 0;
	    size[0] = size[1] = size[2] = 1;
	    nelmts = 1;
	} else {
	    for (i=0, nelmts=1; i<(size_t)ndims; i++) {
		if (ctr % ndims == i) {
		    offset[i] = max_corner[i];
		    size[i] = MIN(1, whole_size[i] - offset[i]);
		} else {
		    offset[i] = 0;
		    size[i] = max_corner[i];
		}
		nelmts *= size[i];
	    }
	}

#if 0
	if (0 == ctr)
	    fprintf(stderr,"\n");
	fprintf(stderr,"    Insert: ctr=%lu, corner=(%ld", (unsigned long)ctr, (long)offset[0]);
	if (ndims > 1)
	    fprintf(stderr,",%ld", (long)offset[1]);
	if (ndims > 2)
	    fprintf(stderr,",%ld", (long)offset[2]);
	fprintf(stderr,"), size=(%lu", (unsigned long)size[0]);
	if (ndims > 1)
	    fprintf(stderr,",%lu", (unsigned long)size[1]);
	if (ndims > 2)
	    fprintf(stderr,",%lu", (unsigned long)size[2]);
	fprintf(stderr,"), %lu element%s", (unsigned long)nelmts, 1 == nelmts ? "" : "s");
	if (0 == nelmts)
	    fprintf(stderr," *SKIPPED*");
	fprintf(stderr,"\n");
#endif

	/* Fill the source array */
	if (0 == nelmts) continue;
	HDmemset(buf, (signed)(128+ctr), (size_t)nelmts);

        /* Create dataspace for selection in memory */
        if((mspace=H5Screate_simple(1,&nelmts,NULL))<0) TEST_ERROR;

        /* Select region in file dataspace */
        if(H5Sselect_hyperslab(fspace,H5S_SELECT_SET,offset,NULL,size,NULL)<0) TEST_ERROR;

	/* Write to disk */
	if (H5Dwrite(dataset, TEST_DATATYPE, mspace, fspace, H5P_DEFAULT, buf)<0) {
	    H5_FAILED();
	    fprintf(stderr,"    Write failed: ctr=%lu\n", (unsigned long)ctr);
	    goto error;
	}

	/* Read from disk */
	HDmemset(check, 0xff, (size_t)nelmts);
	if (H5Dread(dataset, TEST_DATATYPE, mspace, fspace, H5P_DEFAULT, check)<0) {
	    H5_FAILED();
	    fprintf(stderr,"    Read failed: ctr=%lu\n", (unsigned long)ctr);
	    goto error;
	}
	if (HDmemcmp(buf, check, (size_t)nelmts)) {
	    H5_FAILED();
	    fprintf(stderr,"    Read check failed: ctr=%lu\n", (unsigned long)ctr);
	    fprintf(stderr,"    Wrote:\n");
	    print_array(buf, (size_t)size[0], (size_t)size[1],
			(size_t)size[2]);
	    fprintf(stderr,"    Read:\n");
	    print_array(check, (size_t)size[0], (size_t)size[1],
			(size_t)size[2]);
	    goto error;
	}

        /* Close memory dataspace */
        if(H5Sclose(mspace)<0) TEST_ERROR;

	/* Write to `whole' buffer for later checking */
	H5V_hyper_copy((unsigned)ndims, size,
		       whole_size, offset, whole,	/*dst*/
		       size, H5V_ZERO, buf);		/*src*/

	/* Update max corner */
	for (i=0; i<(size_t)ndims; i++)
	    max_corner[i] = MAX(max_corner[i], offset[i]+size[i]);
    }

    /* Now read the entire array back out and check it */
    HDmemset(buf, 0xff, nx * ny * nz);
    if (H5Dread(dataset, TEST_DATATYPE, H5S_ALL, H5S_ALL, H5P_DEFAULT, buf)<0) {
	H5_FAILED();
	fprintf(stderr,"    Read failed for whole array.\n");
	goto error;
    }
    for (i=0; i<nx; i++) {
	for (j=0; j<ny; j++) {
	    for (k=0; k<nz; k++) {
		if (whole[i*ny*nz + j*nz + k] != buf[i*ny*nz + j*nz + k]) {
		    H5_FAILED();
		    fprintf(stderr,"    Check failed at i=%lu", (unsigned long)i);
		    if (ndims > 1) {
			fprintf(stderr,", j=%lu", (unsigned long)j);
		    }
		    if (ndims > 2) {
			fprintf(stderr,", k=%lu", (unsigned long)k);
		    }
		    fprintf(stderr,"\n    Check array is:\n");
		    print_array(whole, nx, ny, nz);
		    fprintf(stderr,"    Value read is:\n");
		    print_array(buf, nx, ny, nz);
		    goto error;
		}
	    }
	}
    }

    /* Close dataset's dataspace */
    if(H5Sclose(fspace)<0) TEST_ERROR;

    /* Close dataset */
    if(H5Dclose(dataset)<0) TEST_ERROR;

    /* Free memory used */
    HDfree(buf);
    HDfree(check);
    HDfree(whole);

    PASSED();
    return SUCCEED;

error:
    HDfree(buf);
    HDfree(check);
    HDfree(whole);
    return FAIL;
}


/*-------------------------------------------------------------------------
 * Function:	test_sparse
 *
 * Purpose:	Creates a sparse matrix consisting of NBLOCKS randomly placed
 *		blocks each of size NX,NY,NZ.
 *
 * Return:	Success:	SUCCEED
 *
 *		Failure:	FAIL
 *
 * Programmer:	Robb Matzke
 *		Wednesday, October 22, 1997
 *
 * Modifications:
 *
 *-------------------------------------------------------------------------
 */
static herr_t
test_sparse(hid_t f, const char *prefix, size_t nblocks,
	    size_t nx, size_t ny, size_t nz)
{
    hid_t               dataset;        /* Dataset ID */
    hid_t               fspace;         /* Dataset's file dataspace */
    hid_t               mspace;         /* Dataset's memory dataspace */
    int			ndims;
    hsize_t		ctr;
    char		dims[64], s[256], name[256];
    hsize_t		offset[3];
    hsize_t		size[3], total = 0;
    uint8_t		*buf = NULL;
    hsize_t		whole_size[3];  /* Size of dataset's dataspace */
    size_t              u;              /* Local index variable */

    if (!nz) {
	if (!ny) {
	    ndims = 1;
	    ny = nz = 1;
	    sprintf(dims, "%lu", (unsigned long) nx);
	} else {
	    ndims = 2;
	    nz = 1;
	    sprintf(dims, "%lux%lu", (unsigned long) nx, (unsigned long) ny);
	}
    } else {
	ndims = 3;
	sprintf(dims, "%lux%lux%lu",
		(unsigned long) nx, (unsigned long) ny, (unsigned long) nz);
    }

    sprintf(s, "istore sparse: %s", dims);
    TESTING(s);
    buf = HDmalloc(nx * ny * nz);
    HDmemset(buf, 128, nx * ny * nz);

    /* Set dimensions of dataset */
    for (u=0; u<(size_t)ndims; u++)
        whole_size[u]=TEST_SPARSE_SIZE;

    /* Set dimensions of selection */
    size[0] = nx;
    size[1] = ny;
    size[2] = nz;

    /* Build the new empty object */
    sprintf(name, "%s_%s", prefix, dims);
    if ((dataset=new_object(f, name, ndims, whole_size, chunk_dims)) < 0) {
	printf("    Cannot create %u-d object `%s'\n", ndims, name);
	goto error;
    }

    /* Get dataset's dataspace */
    if((fspace=H5Dget_space(dataset))<0) TEST_ERROR;

    /* Create dataspace for memory buffer */
    if((mspace=H5Screate_simple(ndims,size,NULL))<0) TEST_ERROR;

    for (ctr=0; ctr<nblocks; ctr++) {
	offset[0] = (hsize_t)(HDrandom() % (TEST_SPARSE_SIZE-nx));
	offset[1] = (hsize_t)(HDrandom() % (TEST_SPARSE_SIZE-ny));
	offset[2] = (hsize_t)(HDrandom() % (TEST_SPARSE_SIZE-nz));

        /* Select region in file dataspace */
        if(H5Sselect_hyperslab(fspace,H5S_SELECT_SET,offset,NULL,size,NULL)<0) TEST_ERROR;

	/* write to disk */
	if (H5Dwrite(dataset, TEST_DATATYPE, mspace, fspace, H5P_DEFAULT, buf)<0) {
	    H5_FAILED();
	    printf("    Write failed: ctr=%lu\n", (unsigned long)ctr);
	    printf("    offset=(%lu", (unsigned long) (offset[0]));
	    if (ndims > 1)
		printf(",%lu", (unsigned long) (offset[1]));
	    if (ndims > 2)
		printf(",%lu", (unsigned long) (offset[2]));
	    printf("), size=(%lu", (unsigned long) (size[0]));
	    if (ndims > 1)
		printf(",%lu", (unsigned long) (size[1]));
	    if (ndims > 2)
		printf(",%lu", (unsigned long) (size[2]));
	    printf(")\n");
	    goto error;
	}
	total += nx * ny * nz;
#if 0
	HDfprintf(stderr,"ctr: ctr=%Zu, total=%Zu\n", ctr, total);
#endif

	/* We don't test reading yet.... */
    }

    /* Close memory dataspace */
    if(H5Sclose(mspace)<0) TEST_ERROR;

    /* Close dataset's dataspace */
    if(H5Sclose(fspace)<0) TEST_ERROR;

    /* Close dataset */
    if(H5Dclose(dataset)<0) TEST_ERROR;

    HDfree(buf);
    PASSED();
    return SUCCEED;

error:
    HDfree(buf);
    return FAIL;
}


/*-------------------------------------------------------------------------
 * Function:	main
 *
 * Purpose:	Tests indexed storage stuff.
 *
 * Return:	Success:	exit(0)
 *
 *		Failure:	exit(non-zero)
 *
 * Programmer:	Robb Matzke
 *		Wednesday, October 15, 1997
 *
 * Modifications:
 *
 *-------------------------------------------------------------------------
 */
int
main(int argc, char *argv[])
{
    hid_t		fapl=-1, file=-1, fcpl=-1;
    herr_t		status;
    int			nerrors = 0;
    unsigned		size_of_test;
    unsigned            u;              /* Local index variable */
    char		filename[1024];

    /* Parse arguments or assume these tests (`small', `medium' ) */
    if (1 == argc) {
	size_of_test = TEST_SMALL;
    } else {
	int			i;
	for (i = 1, size_of_test = 0; i < argc; i++) {
	    if (!strcmp(argv[i], "small")) {
		size_of_test |= TEST_SMALL;
	    } else if (!strcmp(argv[i], "medium")) {
		size_of_test |= TEST_MEDIUM;
	    } else if (!strcmp(argv[i], "large")) {
		size_of_test |= TEST_LARGE;
	    } else {
		printf("unrecognized argument: %s\n", argv[i]);
#if 0
		exit(1);
#endif
	    }
	}
    }
    printf("Test sizes: ");
    if (size_of_test & TEST_SMALL)
	printf(" SMALL");
    if (size_of_test & TEST_MEDIUM)
	printf(" MEDIUM");
    if (size_of_test & TEST_LARGE)
	printf(" LARGE");
    printf("\n");

    /* Set the random # seed */
    HDsrandom((unsigned long)HDtime(NULL));

    /* Reset library */
    h5_reset();
    fapl = h5_fileaccess();

    /* Use larger file addresses... */
    fcpl = H5Pcreate(H5P_FILE_CREATE);
    H5Pset_sizes(fcpl, 8, 0);

    /* Create the test file */
    h5_fixname(FILENAME[0], fapl, filename, sizeof filename);
    if ((file=H5Fcreate(filename, H5F_ACC_TRUNC, fcpl, fapl))<0) {
	printf("Cannot create file %s; test aborted\n", filename);
	exit(1);
    }

    /*
     * For testing file families, fool the library into thinking it already
     * allocated a whole bunch of data.
     */
    if (H5FD_FAMILY==H5Pget_driver(fapl)) {
	haddr_t addr;
        H5F_t		*f;

	addr = 8 * ((uint64_t)1<<30);	/*8 GB */
	f=H5I_object(file);
	if (H5FDset_eoa(f->shared->lf, addr)<0) {
	    printf("Cannot create large file family\n");
	    exit(1);
	}
    }

    /* Initialize chunk dimensions */
    for (u = 0; u < H5O_LAYOUT_NDIMS; u++)
        chunk_dims[u]=TEST_CHUNK_SIZE;

    /*
     * Creation test: Creates empty objects with various raw data sizes
     * and alignments.
     */
    status = test_create(file, "create");
    nerrors += status < 0 ? 1 : 0;

    if (size_of_test & TEST_SMALL) {
	status = test_extend(file, "extend", 10, 0, 0);
	nerrors += status < 0 ? 1 : 0;
	status = test_extend(file, "extend", 10, 10, 0);
	nerrors += status < 0 ? 1 : 0;
	status = test_extend(file, "extend", 10, 10, 10);
	nerrors += status < 0 ? 1 : 0;
    }
    if (size_of_test & TEST_MEDIUM) {
	status = test_extend(file, "extend", 10000, 0, 0);
	nerrors += status < 0 ? 1 : 0;
	status = test_extend(file, "extend", 2500, 10, 0);
	nerrors += status < 0 ? 1 : 0;
	status = test_extend(file, "extend", 10, 400, 10);
	nerrors += status < 0 ? 1 : 0;
    }
    if (size_of_test & TEST_SMALL) {
	status = test_sparse(file, "sparse", 100, 5, 0, 0);
	nerrors += status < 0 ? 1 : 0;
	status = test_sparse(file, "sparse", 100, 3, 4, 0);
	nerrors += status < 0 ? 1 : 0;
	status = test_sparse(file, "sparse", 100, 2, 3, 4);
	nerrors += status < 0 ? 1 : 0;
    }
    if (size_of_test & TEST_MEDIUM) {
	status = test_sparse(file, "sparse", 1000, 30, 0, 0);
	nerrors += status < 0 ? 1 : 0;
	status = test_sparse(file, "sparse", 2000, 7, 3, 0);
	nerrors += status < 0 ? 1 : 0;
	status = test_sparse(file, "sparse", 2000, 4, 2, 3);
	nerrors += status < 0 ? 1 : 0;
    }
    if (size_of_test & TEST_LARGE) {
	status = test_sparse(file, "sparse", 800, 50, 50, 50);
	nerrors += status < 0 ? 1 : 0;
    }

    /* Close the test file and exit */
    H5Pclose(fcpl);
    H5Fclose(file);

    if (nerrors) {
	printf("***** %d I-STORE TEST%s FAILED! *****\n",
	       nerrors, 1 == nerrors ? "" : "S");
	exit(1);
    }

    printf("All i-store tests passed.\n");
    h5_cleanup(FILENAME, fapl);
    return 0;
}
class='add'>+ * returns either.
+ *
+ * Side effects:
+ * Whatever the application does.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+main(argc, argv)
+ int argc; /* Number of command-line arguments. */
+ char **argv; /* Values of command-line arguments. */
+{
+ char *p;
+ char buffer[MAX_PATH];
+
+ /*
+ * Set up the default locale to be standard "C" locale so parsing
+ * is performed correctly.
+ */
+
+ setlocale(LC_ALL, "C");
+
+ setargv(&argc, &argv);
+
+ /*
+ * Replace argv[0] with full pathname of executable, and forward
+ * slashes substituted for backslashes.
+ */
+
+ GetModuleFileName(NULL, buffer, sizeof(buffer));
+ argv[0] = buffer;
+ for (p = buffer; *p != '\0'; p++) {
+ if (*p == '\\') {
+ *p = '/';
+ }
+ }
+
+ Tcl_Main(argc, argv, Tcl_AppInit);
+ return 0; /* Needed only to prevent compiler warning. */
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_AppInit --
+ *
+ * This procedure performs application-specific initialization.
+ * Most applications, especially those that incorporate additional
+ * packages, will have their own version of this procedure.
+ *
+ * Results:
+ * Returns a standard Tcl completion code, and leaves an error
+ * message in interp->result if an error occurs.
+ *
+ * Side effects:
+ * Depends on the startup script.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_AppInit(interp)
+ Tcl_Interp *interp; /* Interpreter for application. */
+{
+ if (Tcl_Init(interp) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+
+#ifdef TCL_TEST
+ if (Tcltest_Init(interp) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+ Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init,
+ (Tcl_PackageInitProc *) NULL);
+ if (TclObjTest_Init(interp) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+#endif /* TCL_TEST */
+
+ /*
+ * Call the init procedures for included packages. Each call should
+ * look like this:
+ *
+ * if (Mod_Init(interp) == TCL_ERROR) {
+ * return TCL_ERROR;
+ * }
+ *
+ * where "Mod" is the name of the module.
+ */
+
+ /*
+ * Call Tcl_CreateCommand for application-specific commands, if
+ * they weren't already created by the init procedures called above.
+ */
+
+ /*
+ * Specify a user-specific startup file to invoke if the application
+ * is run interactively. Typically the startup file is "~/.apprc"
+ * where "app" is the name of the application. If this line is deleted
+ * then no user-specific startup file will be run under any conditions.
+ */
+
+ Tcl_SetVar(interp, "tcl_rcFileName", "~/tclshrc.tcl", TCL_GLOBAL_ONLY);
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * setargv --
+ *
+ * Parse the Windows command line string into argc/argv. Done here
+ * because we don't trust the builtin argument parser in crt0.
+ * Windows applications are responsible for breaking their command
+ * line into arguments.
+ *
+ * 2N backslashes + quote -> N backslashes + begin quoted string
+ * 2N + 1 backslashes + quote -> literal
+ * N backslashes + non-quote -> literal
+ * quote + quote in a quoted string -> single quote
+ * quote + quote not in quoted string -> empty string
+ * quote -> begin quoted string
+ *
+ * Results:
+ * Fills argcPtr with the number of arguments and argvPtr with the
+ * array of arguments.
+ *
+ * Side effects:
+ * Memory allocated.
+ *
+ *--------------------------------------------------------------------------
+ */
+
+static void
+setargv(argcPtr, argvPtr)
+ int *argcPtr; /* Filled with number of argument strings. */
+ char ***argvPtr; /* Filled with argument strings (malloc'd). */
+{
+ char *cmdLine, *p, *arg, *argSpace;
+ char **argv;
+ int argc, size, inquote, copy, slashes;
+
+ cmdLine = GetCommandLine();
+
+ /*
+ * Precompute an overly pessimistic guess at the number of arguments
+ * in the command line by counting non-space spans.
+ */
+
+ size = 2;
+ for (p = cmdLine; *p != '\0'; p++) {
+ if (isspace(*p)) {
+ size++;
+ while (isspace(*p)) {
+ p++;
+ }
+ if (*p == '\0') {
+ break;
+ }
+ }
+ }
+ argSpace = (char *) ckalloc((unsigned) (size * sizeof(char *)
+ + strlen(cmdLine) + 1));
+ argv = (char **) argSpace;
+ argSpace += size * sizeof(char *);
+ size--;
+
+ p = cmdLine;
+ for (argc = 0; argc < size; argc++) {
+ argv[argc] = arg = argSpace;
+ while (isspace(*p)) {
+ p++;
+ }
+ if (*p == '\0') {
+ break;
+ }
+
+ inquote = 0;
+ slashes = 0;
+ while (1) {
+ copy = 1;
+ while (*p == '\\') {
+ slashes++;
+ p++;
+ }
+ if (*p == '"') {
+ if ((slashes & 1) == 0) {
+ copy = 0;
+ if ((inquote) && (p[1] == '"')) {
+ p++;
+ copy = 1;
+ } else {
+ inquote = !inquote;
+ }
+ }
+ slashes >>= 1;
+ }
+
+ while (slashes) {
+ *arg = '\\';
+ arg++;
+ slashes--;
+ }
+
+ if ((*p == '\0') || (!inquote && isspace(*p))) {
+ break;
+ }
+ if (copy != 0) {
+ *arg = *p;
+ arg++;
+ }
+ p++;
+ }
+ *arg = '\0';
+ argSpace = arg + 1;
+ }
+ argv[argc] = NULL;
+
+ *argcPtr = argc;
+ *argvPtr = argv;
+}
diff --git a/win/tclWin16.c b/win/tclWin16.c
new file mode 100644
index 0000000..d8ea801
--- /dev/null
+++ b/win/tclWin16.c
@@ -0,0 +1,347 @@
+/*
+ * tclWin16.c --
+ *
+ * This file contains code for a 16-bit DLL to handle 32-to-16 bit
+ * thunking. This is necessary for the Win32s SynchSpawn() call.
+ *
+ * Copyright (c) 1994-1997 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclWin16.c 1.18 97/05/23 13:13:32
+ */
+
+#define STRICT
+
+#include <windows.h>
+#include <toolhelp.h>
+
+#include <stdio.h>
+#include <string.h>
+
+static int WinSpawn(char *command);
+static int DosSpawn(char *command, char *fromFileName,
+ char *toFileName);
+static int WaitForExit(int inst);
+
+/*
+ * The following data is used to construct a .pif file that wraps the
+ * .bat file that runs the 16-bit application (that Jack built).
+ * The .pif file causes the .bat file to run in an iconified window.
+ * Otherwise, when we try to exec something, a DOS box pops up,
+ * obscuring everything, and then almost immediately flickers out of
+ * existence, which is rather disconcerting.
+ */
+
+static char pifData[545] = {
+'\000', '\013', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\200', '\000', '\200', '\000', '\103', '\117', '\115', '\115',
+'\101', '\116', '\104', '\056', '\103', '\117', '\115', '\000',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\020', '\000', '\000', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\177', '\001', '\000',
+'\377', '\031', '\120', '\000', '\000', '\007', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\340',
+'\040', '\115', '\111', '\103', '\122', '\117', '\123', '\117',
+'\106', '\124', '\040', '\120', '\111', '\106', '\105', '\130',
+'\000', '\207', '\001', '\000', '\000', '\161', '\001', '\127',
+'\111', '\116', '\104', '\117', '\127', '\123', '\040', '\063',
+'\070', '\066', '\040', '\063', '\056', '\060', '\000', '\005',
+'\002', '\235', '\001', '\150', '\000', '\200', '\002', '\200',
+'\000', '\144', '\000', '\062', '\000', '\000', '\004', '\000',
+'\000', '\000', '\004', '\000', '\000', '\002', '\020', '\002',
+'\000', '\037', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\057', '\143', '\040',
+'\146', '\157', '\157', '\056', '\142', '\141', '\164', '\000',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\127', '\111', '\116',
+'\104', '\117', '\127', '\123', '\040', '\062', '\070', '\066',
+'\040', '\063', '\056', '\060', '\000', '\377', '\377', '\033',
+'\002', '\006', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000'
+};
+
+static HINSTANCE hInstance;
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * LibMain --
+ *
+ * 16-bit DLL entry point.
+ *
+ * Results:
+ * Returns 1.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int CALLBACK
+LibMain(
+ HINSTANCE hinst,
+ WORD wDS,
+ WORD cbHeap,
+ LPSTR unused)
+{
+ hInstance = hinst;
+ wDS = wDS; /* lint. */
+ cbHeap = cbHeap; /* lint. */
+ unused = unused; /* lint. */
+
+ return TRUE;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * UTProc --
+ *
+ * Universal Thunk dispatch routine. Executes a 16-bit DOS
+ * application or a 16-bit or 32-bit Windows application and
+ * waits for it to complete.
+ *
+ * Results:
+ * 1 if the application could be run, 0 or -1 on failure.
+ *
+ * Side effects:
+ * Executes 16-bit code.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int WINAPI
+UTProc(buf, func)
+ void *buf;
+ DWORD func;
+{
+ char **args;
+
+ args = (char **) buf;
+ if (func == 0) {
+ return DosSpawn(args[0], args[1], args[2]);
+ } else {
+ return WinSpawn(args[0]);
+ }
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * WinSpawn --
+ *
+ * Start a 16-bit or 32-bit Windows application with optional
+ * command line arguments and wait for it to finish. Windows
+ * applications do not handle input/output redirection.
+ *
+ * Results:
+ * The return value is 1 if the application could be run, 0 otherwise.
+ *
+ * Side effects:
+ * Whatever the application does.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+WinSpawn(command)
+ char *command; /* The command line, consisting of the name
+ * of the executable to run followed by any
+ * number of arguments to the executable. */
+{
+ return WaitForExit(WinExec(command, SW_SHOW));
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * DosSpawn --
+ *
+ * Start a 16-bit DOS program with optional command line arguments
+ * and wait for it to finish. Input and output can be redirected
+ * from the specified files, but there is no such thing as stderr
+ * under Win32s.
+ *
+ * This procedure to constructs a temporary .pif file that wraps a
+ * temporary .bat file that runs the 16-bit application. The .bat
+ * file is necessary to get the redirection symbols '<' and '>' to
+ * work, because WinExec() doesn't accept them. The .pif file is
+ * necessary to cause the .bat file to run in an iconified window,
+ * to avoid having a large DOS box pop up, obscuring everything, and
+ * then almost immediately flicker out of existence, which is rather
+ * disconcerting.
+ *
+ * Results:
+ * The return value is 1 if the application could be run, 0 otherwise.
+ *
+ * Side effects:
+ * Whatever the application does.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static int
+DosSpawn(command, fromFileName, toFileName)
+ char *command; /* The name of the program, plus any
+ * arguments, to be run. */
+ char *fromFileName; /* Standard input for the program is to be
+ * redirected from this file, or NULL for no
+ * standard input. */
+ char *toFileName; /* Standard output for the program is to be
+ * redirected to this file, or NULL to
+ * discard standard output. */
+{
+ int result;
+ HFILE batFile, pifFile;
+ char batFileName[144], pifFileName[144];
+
+ GetTempFileName(0, "tcl", 0, batFileName);
+ unlink(batFileName);
+ strcpy(strrchr(batFileName, '.'), ".bat");
+ batFile = _lcreat(batFileName, 0);
+
+ GetTempFileName(0, "tcl", 0, pifFileName);
+ unlink(pifFileName);
+ strcpy(strrchr(pifFileName, '.'), ".pif");
+ pifFile = _lcreat(pifFileName, 0);
+
+ _lwrite(batFile, command, strlen(command));
+ if (fromFileName == NULL) {
+ _lwrite(batFile, " < nul", 6);
+ } else {
+ _lwrite(batFile, " < ", 3);
+ _lwrite(batFile, fromFileName, strlen(fromFileName));
+ }
+ if (toFileName == NULL) {
+ _lwrite(batFile, " > nul", 6);
+ } else {
+ _lwrite(batFile, " > ", 3);
+ _lwrite(batFile, toFileName, strlen(toFileName));
+ }
+ _lwrite(batFile, "\r\n\032", 3);
+ _lclose(batFile);
+
+ strcpy(pifData + 0x1c8, batFileName);
+ _lwrite(pifFile, pifData, sizeof(pifData));
+ _lclose(pifFile);
+
+ result = WaitForExit(WinExec(pifFileName, SW_MINIMIZE));
+
+ unlink(pifFileName);
+ unlink(batFileName);
+
+ return result;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * WaitForExit --
+ *
+ * Wait until the application with the given instance handle has
+ * finished. PeekMessage() is used to yield the processor;
+ * otherwise, nothing else could execute on the system.
+ *
+ * Results:
+ * The return value is 1 if the process exited successfully,
+ * or 0 otherwise.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static int
+WaitForExit(inst)
+ int inst; /* Identifies the instance handle of the
+ * process to wait for. */
+{
+ TASKENTRY te;
+ MSG msg;
+ UINT timer;
+
+ if (inst < 32) {
+ return 0;
+ }
+
+ te.dwSize = sizeof(te);
+ te.hInst = 0;
+ TaskFirst(&te);
+ do {
+ if (te.hInst == (HINSTANCE) inst) {
+ break;
+ }
+ } while (TaskNext(&te) != FALSE);
+
+ if (te.hInst != (HINSTANCE) inst) {
+ return 0;
+ }
+
+ timer = SetTimer(NULL, 0, 0, NULL);
+ while (1) {
+ if (GetMessage(&msg, NULL, 0, 0) != 0) {
+ TranslateMessage(&msg);
+ DispatchMessage(&msg);
+ }
+ TaskFirst(&te);
+ do {
+ if (te.hInst == (HINSTANCE) inst) {
+ break;
+ }
+ } while (TaskNext(&te) != FALSE);
+
+ if (te.hInst != (HINSTANCE) inst) {
+ KillTimer(NULL, timer);
+ return 1;
+ }
+ }
+}
diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c
new file mode 100644
index 0000000..3abc97e
--- /dev/null
+++ b/win/tclWin32Dll.c
@@ -0,0 +1,362 @@
+/*
+ * tclWin32Dll.c --
+ *
+ * This file contains the DLL entry point which sets up the 32-to-16-bit
+ * thunking code for SynchSpawn if the library is running under Win32s.
+ *
+ * Copyright (c) 1995-1996 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclWin32Dll.c 1.21 97/08/05 11:47:10
+ */
+
+#include "tclWinInt.h"
+
+typedef DWORD (WINAPI * UT32PROC)(LPVOID lpBuff, DWORD dwUserDefined,
+ LPVOID *lpTranslationList);
+
+typedef BOOL (WINAPI * PUTREGISTER)(HANDLE hModule, LPCSTR SixteenBitDLL,
+ LPCSTR InitName, LPCSTR ProcName, UT32PROC* ThirtyTwoBitThunk,
+ FARPROC UT32Callback, LPVOID Buff);
+
+typedef VOID (WINAPI * PUTUNREGISTER)(HANDLE hModule);
+
+static PUTUNREGISTER UTUnRegister = NULL;
+static int tclProcessesAttached = 0;
+
+/*
+ * The following data structure is used to keep track of all of the DLL's
+ * opened by Tcl so that they can be freed with the Tcl.dll is unloaded.
+ */
+
+typedef struct LibraryList {
+ HINSTANCE handle;
+ struct LibraryList *nextPtr;
+} LibraryList;
+
+static LibraryList *libraryList = NULL; /* List of currently loaded DLL's. */
+
+static HINSTANCE tclInstance; /* Global library instance handle. */
+static int tclPlatformId; /* Running under NT, 95, or Win32s? */
+
+/*
+ * Declarations for functions that are only used in this file.
+ */
+
+static void UnloadLibraries _ANSI_ARGS_((void));
+
+/*
+ * The following declaration is for the VC++ DLL entry point.
+ */
+
+BOOL APIENTRY DllMain _ANSI_ARGS_((HINSTANCE hInst,
+ DWORD reason, LPVOID reserved));
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DllEntryPoint --
+ *
+ * This wrapper function is used by Borland to invoke the
+ * initialization code for Tcl. It simply calls the DllMain
+ * routine.
+ *
+ * Results:
+ * See DllMain.
+ *
+ * Side effects:
+ * See DllMain.
+ *
+ *----------------------------------------------------------------------
+ */
+
+BOOL APIENTRY
+DllEntryPoint(hInst, reason, reserved)
+ HINSTANCE hInst; /* Library instance handle. */
+ DWORD reason; /* Reason this function is being called. */
+ LPVOID reserved; /* Not used. */
+{
+ return DllMain(hInst, reason, reserved);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DllMain --
+ *
+ * This routine is called by the VC++ C run time library init
+ * code, or the DllEntryPoint routine. It is responsible for
+ * initializing various dynamically loaded libraries.
+ *
+ * Results:
+ * TRUE on sucess, FALSE on failure.
+ *
+ * Side effects:
+ * Establishes 32-to-16 bit thunk and initializes sockets library.
+ *
+ *----------------------------------------------------------------------
+ */
+BOOL APIENTRY
+DllMain(hInst, reason, reserved)
+ HINSTANCE hInst; /* Library instance handle. */
+ DWORD reason; /* Reason this function is being called. */
+ LPVOID reserved; /* Not used. */
+{
+ OSVERSIONINFO os;
+
+ switch (reason) {
+ case DLL_PROCESS_ATTACH:
+
+ /*
+ * Registration of UT need to be done only once for first
+ * attaching process. At that time set the tclWin32s flag
+ * to indicate if the DLL is executing under Win32s or not.
+ */
+
+ if (tclProcessesAttached++) {
+ return FALSE; /* Not the first initialization. */
+ }
+
+ tclInstance = hInst;
+ os.dwOSVersionInfoSize = sizeof(os);
+ GetVersionEx(&os);
+ tclPlatformId = os.dwPlatformId;
+
+ /*
+ * The following code stops Windows 3.x from automatically putting
+ * up Sharing Violation dialogs, e.g, when someone tries to
+ * access a file that is locked or a drive with no disk in it.
+ * Tcl already returns the appropriate error to the caller, and they
+ * can decide to put up their own dialog in response to that failure.
+ *
+ * Under 95 and NT, the system doesn't automatically put up dialogs
+ * when the above operations fail.
+ */
+
+ if (tclPlatformId == VER_PLATFORM_WIN32s) {
+ SetErrorMode(SetErrorMode(0) | SEM_FAILCRITICALERRORS);
+ }
+
+ return TRUE;
+
+ case DLL_PROCESS_DETACH:
+
+ tclProcessesAttached--;
+ if (tclProcessesAttached == 0) {
+
+ /*
+ * Unregister the Tcl thunk.
+ */
+
+ if (UTUnRegister != NULL) {
+ UTUnRegister(hInst);
+ }
+
+ /*
+ * Cleanup any dynamically loaded libraries.
+ */
+
+ UnloadLibraries();
+
+ /*
+ * And finally finalize our use of Tcl.
+ */
+
+ Tcl_Finalize();
+ }
+ break;
+ }
+
+ return TRUE;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclWinLoadLibrary --
+ *
+ * This function is a wrapper for the system LoadLibrary. It is
+ * responsible for adding library handles to the library list so
+ * the libraries can be freed when tcl.dll is unloaded.
+ *
+ * Results:
+ * Returns the handle of the newly loaded library, or NULL on
+ * failure.
+ *
+ * Side effects:
+ * Loads the specified library into the process.
+ *
+ *----------------------------------------------------------------------
+ */
+
+HINSTANCE
+TclWinLoadLibrary(name)
+ char *name; /* Library file to load. */
+{
+ HINSTANCE handle;
+ LibraryList *ptr;
+
+ handle = LoadLibrary(name);
+ if (handle != NULL) {
+ ptr = (LibraryList*) ckalloc(sizeof(LibraryList));
+ ptr->handle = handle;
+ ptr->nextPtr = libraryList;
+ libraryList = ptr;
+ } else {
+ TclWinConvertError(GetLastError());
+ }
+ return handle;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * UnloadLibraries --
+ *
+ * Frees any dynamically allocated libraries loaded by Tcl.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Frees the libraries on the library list as well as the list.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+UnloadLibraries()
+{
+ LibraryList *ptr;
+
+ while (libraryList != NULL) {
+ FreeLibrary(libraryList->handle);
+ ptr = libraryList->nextPtr;
+ ckfree((char*)libraryList);
+ libraryList = ptr;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclWinSynchSpawn --
+ *
+ * 32-bit entry point to the 16-bit SynchSpawn code.
+ *
+ * Results:
+ * 1 on success, 0 on failure.
+ *
+ * Side effects:
+ * Spawns a command and waits for it to complete.
+ *
+ *----------------------------------------------------------------------
+ */
+int
+TclWinSynchSpawn(void *args, int type, void **trans, Tcl_Pid *pidPtr)
+{
+ static UT32PROC UTProc = NULL;
+ static int utErrorCode;
+
+ if (UTUnRegister == NULL) {
+ /*
+ * Load the Universal Thunking routines from kernel32.dll.
+ */
+
+ HINSTANCE hKernel;
+ PUTREGISTER UTRegister;
+ char buffer[] = "TCL16xx.DLL";
+
+ hKernel = TclWinLoadLibrary("Kernel32.Dll");
+ if (hKernel == NULL) {
+ return 0;
+ }
+
+ UTRegister = (PUTREGISTER) GetProcAddress(hKernel, "UTRegister");
+ UTUnRegister = (PUTUNREGISTER) GetProcAddress(hKernel, "UTUnRegister");
+ if (!UTRegister || !UTUnRegister) {
+ UnloadLibraries();
+ return 0;
+ }
+
+ /*
+ * Construct the complete name of tcl16xx.dll.
+ */
+
+ buffer[5] = '0' + TCL_MAJOR_VERSION;
+ buffer[6] = '0' + TCL_MINOR_VERSION;
+
+ /*
+ * Register the Tcl thunk.
+ */
+
+ if (UTRegister(tclInstance, buffer, NULL, "UTProc", &UTProc, NULL,
+ NULL) == FALSE) {
+ utErrorCode = GetLastError();
+ }
+ }
+
+ if (UTProc == NULL) {
+ /*
+ * The 16-bit thunking DLL wasn't found. Return error code that
+ * indicates this problem.
+ */
+
+ SetLastError(utErrorCode);
+ return 0;
+ }
+
+ UTProc(args, type, trans);
+ *pidPtr = 0;
+ return 1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclWinGetTclInstance --
+ *
+ * Retrieves the global library instance handle.
+ *
+ * Results:
+ * Returns the global library instance handle.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+HINSTANCE
+TclWinGetTclInstance()
+{
+ return tclInstance;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclWinGetPlatformId --
+ *
+ * Determines whether running under NT, 95, or Win32s, to allow
+ * runtime conditional code.
+ *
+ * Results:
+ * The return value is one of:
+ * VER_PLATFORM_WIN32s Win32s on Windows 3.1.
+ * VER_PLATFORM_WIN32_WINDOWS Win32 on Windows 95.
+ * VER_PLATFORM_WIN32_NT Win32 on Windows NT
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclWinGetPlatformId()
+{
+ return tclPlatformId;
+}
diff --git a/win/tclWinChan.c b/win/tclWinChan.c
new file mode 100644
index 0000000..248e14b
--- /dev/null
+++ b/win/tclWinChan.c
@@ -0,0 +1,1185 @@
+/*
+ * tclWinChan.c
+ *
+ * Channel drivers for Windows channels based on files, command
+ * pipes and TCP sockets.
+ *
+ * Copyright (c) 1995-1997 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclWinChan.c 1.75 97/09/26 16:17:46
+ */
+
+#include "tclWinInt.h"
+
+/*
+ * This is the size of the channel name for File based channels
+ */
+
+#define CHANNEL_NAME_SIZE 64
+static char channelName[CHANNEL_NAME_SIZE+1];
+
+/*
+ * The following variable is used to tell whether this module has been
+ * initialized.
+ */
+
+static int initialized = 0;
+
+/*
+ * State flags used in the info structures below.
+ */
+
+#define FILE_PENDING (1<<0) /* Message is pending in the queue. */
+#define FILE_ASYNC (1<<1) /* Channel is non-blocking. */
+#define FILE_APPEND (1<<2) /* File is in append mode. */
+
+/*
+ * The following structure contains per-instance data for a file based channel.
+ */
+
+typedef struct FileInfo {
+ Tcl_Channel channel; /* Pointer to channel structure. */
+ int validMask; /* OR'ed combination of TCL_READABLE,
+ * TCL_WRITABLE, or TCL_EXCEPTION: indicates
+ * which operations are valid on the file. */
+ int watchMask; /* OR'ed combination of TCL_READABLE,
+ * TCL_WRITABLE, or TCL_EXCEPTION: indicates
+ * which events should be reported. */
+ int flags; /* State flags, see above for a list. */
+ HANDLE handle; /* Input/output file. */
+ struct FileInfo *nextPtr; /* Pointer to next registered file. */
+} FileInfo;
+
+/*
+ * List of all file channels currently open.
+ */
+
+static FileInfo *firstFilePtr;
+
+/*
+ * The following structure is what is added to the Tcl event queue when
+ * file events are generated.
+ */
+
+typedef struct FileEvent {
+ Tcl_Event header; /* Information that is standard for
+ * all events. */
+ FileInfo *infoPtr; /* Pointer to file info structure. Note
+ * that we still have to verify that the
+ * file exists before dereferencing this
+ * pointer. */
+} FileEvent;
+
+/*
+ * Static routines for this file:
+ */
+
+static int ComGetOptionProc _ANSI_ARGS_((ClientData instanceData,
+ Tcl_Interp *interp, char *optionName,
+ Tcl_DString *dsPtr));
+static int ComInputProc _ANSI_ARGS_((ClientData instanceData,
+ char *buf, int toRead, int *errorCode));
+static int ComSetOptionProc _ANSI_ARGS_((ClientData instanceData,
+ Tcl_Interp *interp, char *optionName,
+ char *value));
+static int FileBlockProc _ANSI_ARGS_((ClientData instanceData,
+ int mode));
+static void FileChannelExitHandler _ANSI_ARGS_((
+ ClientData clientData));
+static void FileCheckProc _ANSI_ARGS_((ClientData clientData,
+ int flags));
+static int FileCloseProc _ANSI_ARGS_((ClientData instanceData,
+ Tcl_Interp *interp));
+static int FileEventProc _ANSI_ARGS_((Tcl_Event *evPtr,
+ int flags));
+static int FileGetHandleProc _ANSI_ARGS_((ClientData instanceData,
+ int direction, ClientData *handlePtr));
+static void FileInit _ANSI_ARGS_((void));
+static int FileInputProc _ANSI_ARGS_((ClientData instanceData,
+ char *buf, int toRead, int *errorCode));
+static int FileOutputProc _ANSI_ARGS_((ClientData instanceData,
+ char *buf, int toWrite, int *errorCode));
+static int FileSeekProc _ANSI_ARGS_((ClientData instanceData,
+ long offset, int mode, int *errorCode));
+static void FileSetupProc _ANSI_ARGS_((ClientData clientData,
+ int flags));
+static void FileWatchProc _ANSI_ARGS_((ClientData instanceData,
+ int mask));
+
+
+/*
+ * This structure describes the channel type structure for file based IO.
+ */
+
+static Tcl_ChannelType fileChannelType = {
+ "file", /* Type name. */
+ FileBlockProc, /* Set blocking or non-blocking mode.*/
+ FileCloseProc, /* Close proc. */
+ FileInputProc, /* Input proc. */
+ FileOutputProc, /* Output proc. */
+ FileSeekProc, /* Seek proc. */
+ NULL, /* Set option proc. */
+ NULL, /* Get option proc. */
+ FileWatchProc, /* Set up the notifier to watch the channel. */
+ FileGetHandleProc, /* Get an OS handle from channel. */
+};
+
+static Tcl_ChannelType comChannelType = {
+ "com", /* Type name. */
+ FileBlockProc, /* Set blocking or non-blocking mode.*/
+ FileCloseProc, /* Close proc. */
+ ComInputProc, /* Input proc. */
+ FileOutputProc, /* Output proc. */
+ NULL, /* Seek proc. */
+ ComSetOptionProc, /* Set option proc. */
+ ComGetOptionProc, /* Get option proc. */
+ FileWatchProc, /* Set up notifier to watch the channel. */
+ FileGetHandleProc /* Get an OS handle from channel. */
+};
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FileInit --
+ *
+ * This function creates the window used to simulate file events.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Creates a new window and creates an exit handler.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FileInit()
+{
+ initialized = 1;
+ firstFilePtr = NULL;
+ Tcl_CreateEventSource(FileSetupProc, FileCheckProc, NULL);
+ Tcl_CreateExitHandler(FileChannelExitHandler, NULL);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FileChannelExitHandler --
+ *
+ * This function is called to cleanup the channel driver before
+ * Tcl is unloaded.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Destroys the communication window.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FileChannelExitHandler(clientData)
+ ClientData clientData; /* Old window proc */
+{
+ Tcl_DeleteEventSource(FileSetupProc, FileCheckProc, NULL);
+ initialized = 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FileSetupProc --
+ *
+ * This procedure is invoked before Tcl_DoOneEvent blocks waiting
+ * for an event.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Adjusts the block time if needed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+FileSetupProc(data, flags)
+ ClientData data; /* Not used. */
+ int flags; /* Event flags as passed to Tcl_DoOneEvent. */
+{
+ FileInfo *infoPtr;
+ Tcl_Time blockTime = { 0, 0 };
+
+ if (!(flags & TCL_FILE_EVENTS)) {
+ return;
+ }
+
+ /*
+ * Check to see if there is a ready file. If so, poll.
+ */
+
+ for (infoPtr = firstFilePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
+ if (infoPtr->watchMask) {
+ Tcl_SetMaxBlockTime(&blockTime);
+ break;
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FileCheckProc --
+ *
+ * This procedure is called by Tcl_DoOneEvent to check the file
+ * event source for events.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * May queue an event.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FileCheckProc(data, flags)
+ ClientData data; /* Not used. */
+ int flags; /* Event flags as passed to Tcl_DoOneEvent. */
+{
+ FileEvent *evPtr;
+ FileInfo *infoPtr;
+
+ if (!(flags & TCL_FILE_EVENTS)) {
+ return;
+ }
+
+ /*
+ * Queue events for any ready files that don't already have events
+ * queued (caused by persistent states that won't generate WinSock
+ * events).
+ */
+
+ for (infoPtr = firstFilePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
+ if (infoPtr->watchMask && !(infoPtr->flags & FILE_PENDING)) {
+ infoPtr->flags |= FILE_PENDING;
+ evPtr = (FileEvent *) ckalloc(sizeof(FileEvent));
+ evPtr->header.proc = FileEventProc;
+ evPtr->infoPtr = infoPtr;
+ Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
+ }
+ }
+}
+
+/*----------------------------------------------------------------------
+ *
+ * FileEventProc --
+ *
+ * This function is invoked by Tcl_ServiceEvent when a file event
+ * reaches the front of the event queue. This procedure invokes
+ * Tcl_NotifyChannel on the file.
+ *
+ * Results:
+ * Returns 1 if the event was handled, meaning it should be removed
+ * from the queue. Returns 0 if the event was not handled, meaning
+ * it should stay on the queue. The only time the event isn't
+ * handled is if the TCL_FILE_EVENTS flag bit isn't set.
+ *
+ * Side effects:
+ * Whatever the notifier callback does.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+FileEventProc(evPtr, flags)
+ Tcl_Event *evPtr; /* Event to service. */
+ int flags; /* Flags that indicate what events to
+ * handle, such as TCL_FILE_EVENTS. */
+{
+ FileEvent *fileEvPtr = (FileEvent *)evPtr;
+ FileInfo *infoPtr;
+
+ if (!(flags & TCL_FILE_EVENTS)) {
+ return 0;
+ }
+
+ /*
+ * Search through the list of watched files for the one whose handle
+ * matches the event. We do this rather than simply dereferencing
+ * the handle in the event so that files can be deleted while the
+ * event is in the queue.
+ */
+
+ for (infoPtr = firstFilePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
+ if (fileEvPtr->infoPtr == infoPtr) {
+ infoPtr->flags &= ~(FILE_PENDING);
+ Tcl_NotifyChannel(infoPtr->channel, infoPtr->watchMask);
+ break;
+ }
+ }
+ return 1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FileBlockProc --
+ *
+ * Set blocking or non-blocking mode on channel.
+ *
+ * Results:
+ * 0 if successful, errno when failed.
+ *
+ * Side effects:
+ * Sets the device into blocking or non-blocking mode.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+FileBlockProc(instanceData, mode)
+ ClientData instanceData; /* Instance data for channel. */
+ int mode; /* TCL_MODE_BLOCKING or
+ * TCL_MODE_NONBLOCKING. */
+{
+ FileInfo *infoPtr = (FileInfo *) instanceData;
+
+ /*
+ * Files on Windows can not be switched between blocking and nonblocking,
+ * hence we have to emulate the behavior. This is done in the input
+ * function by checking against a bit in the state. We set or unset the
+ * bit here to cause the input function to emulate the correct behavior.
+ */
+
+ if (mode == TCL_MODE_NONBLOCKING) {
+ infoPtr->flags |= FILE_ASYNC;
+ } else {
+ infoPtr->flags &= ~(FILE_ASYNC);
+ }
+ return 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FileCloseProc --
+ *
+ * Closes the IO channel.
+ *
+ * Results:
+ * 0 if successful, the value of errno if failed.
+ *
+ * Side effects:
+ * Closes the physical channel
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+FileCloseProc(instanceData, interp)
+ ClientData instanceData; /* Pointer to FileInfo structure. */
+ Tcl_Interp *interp; /* Not used. */
+{
+ FileInfo *fileInfoPtr = (FileInfo *) instanceData;
+ FileInfo **nextPtrPtr;
+ int errorCode = 0;
+
+ /*
+ * Remove the file from the watch list.
+ */
+
+ FileWatchProc(instanceData, 0);
+
+ if (CloseHandle(fileInfoPtr->handle) == FALSE) {
+ TclWinConvertError(GetLastError());
+ errorCode = errno;
+ }
+ for (nextPtrPtr = &firstFilePtr; (*nextPtrPtr) != NULL;
+ nextPtrPtr = &((*nextPtrPtr)->nextPtr)) {
+ if ((*nextPtrPtr) == fileInfoPtr) {
+ (*nextPtrPtr) = fileInfoPtr->nextPtr;
+ break;
+ }
+ }
+ ckfree((char *)fileInfoPtr);
+ return errorCode;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FileSeekProc --
+ *
+ * Seeks on a file-based channel. Returns the new position.
+ *
+ * Results:
+ * -1 if failed, the new position if successful. If failed, it
+ * also sets *errorCodePtr to the error code.
+ *
+ * Side effects:
+ * Moves the location at which the channel will be accessed in
+ * future operations.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+FileSeekProc(instanceData, offset, mode, errorCodePtr)
+ ClientData instanceData; /* File state. */
+ long offset; /* Offset to seek to. */
+ int mode; /* Relative to where
+ * should we seek? */
+ int *errorCodePtr; /* To store error code. */
+{
+ FileInfo *infoPtr = (FileInfo *) instanceData;
+ DWORD moveMethod;
+ DWORD newPos;
+
+ *errorCodePtr = 0;
+ if (mode == SEEK_SET) {
+ moveMethod = FILE_BEGIN;
+ } else if (mode == SEEK_CUR) {
+ moveMethod = FILE_CURRENT;
+ } else {
+ moveMethod = FILE_END;
+ }
+
+ newPos = SetFilePointer(infoPtr->handle, offset, NULL, moveMethod);
+ if (newPos == 0xFFFFFFFF) {
+ TclWinConvertError(GetLastError());
+ return -1;
+ }
+ return newPos;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FileInputProc --
+ *
+ * Reads input from the IO channel into the buffer given. Returns
+ * count of how many bytes were actually read, and an error indication.
+ *
+ * Results:
+ * A count of how many bytes were read is returned and an error
+ * indication is returned in an output argument.
+ *
+ * Side effects:
+ * Reads input from the actual channel.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+FileInputProc(instanceData, buf, bufSize, errorCode)
+ ClientData instanceData; /* File state. */
+ char *buf; /* Where to store data read. */
+ int bufSize; /* How much space is available
+ * in the buffer? */
+ int *errorCode; /* Where to store error code. */
+{
+ FileInfo *infoPtr;
+ DWORD bytesRead;
+
+ *errorCode = 0;
+ infoPtr = (FileInfo *) instanceData;
+
+ /*
+ * Note that we will block on reads from a console buffer until a
+ * full line has been entered. The only way I know of to get
+ * around this is to write a console driver. We should probably
+ * do this at some point, but for now, we just block. The same
+ * problem exists for files being read over the network.
+ */
+
+ if (ReadFile(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize, &bytesRead,
+ (LPOVERLAPPED) NULL) != FALSE) {
+ return bytesRead;
+ }
+
+ TclWinConvertError(GetLastError());
+ *errorCode = errno;
+ if (errno == EPIPE) {
+ return 0;
+ }
+ return -1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FileOutputProc --
+ *
+ * Writes the given output on the IO channel. Returns count of how
+ * many characters were actually written, and an error indication.
+ *
+ * Results:
+ * A count of how many characters were written is returned and an
+ * error indication is returned in an output argument.
+ *
+ * Side effects:
+ * Writes output on the actual channel.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+FileOutputProc(instanceData, buf, toWrite, errorCode)
+ ClientData instanceData; /* File state. */
+ char *buf; /* The data buffer. */
+ int toWrite; /* How many bytes to write? */
+ int *errorCode; /* Where to store error code. */
+{
+ FileInfo *infoPtr = (FileInfo *) instanceData;
+ DWORD bytesWritten;
+
+ *errorCode = 0;
+
+ /*
+ * If we are writing to a file that was opened with O_APPEND, we need to
+ * seek to the end of the file before writing the current buffer.
+ */
+
+ if (infoPtr->flags & FILE_APPEND) {
+ SetFilePointer(infoPtr->handle, 0, NULL, FILE_END);
+ }
+
+ if (WriteFile(infoPtr->handle, (LPVOID) buf, (DWORD) toWrite, &bytesWritten,
+ (LPOVERLAPPED) NULL) == FALSE) {
+ TclWinConvertError(GetLastError());
+ *errorCode = errno;
+ return -1;
+ }
+ FlushFileBuffers(infoPtr->handle);
+ return bytesWritten;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FileWatchProc --
+ *
+ * Called by the notifier to set up to watch for events on this
+ * channel.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FileWatchProc(instanceData, mask)
+ ClientData instanceData; /* File state. */
+ int mask; /* What events to watch for; OR-ed
+ * combination of TCL_READABLE,
+ * TCL_WRITABLE and TCL_EXCEPTION. */
+{
+ FileInfo *infoPtr = (FileInfo *) instanceData;
+ Tcl_Time blockTime = { 0, 0 };
+
+ /*
+ * Since the file is always ready for events, we set the block time
+ * to zero so we will poll.
+ */
+
+ infoPtr->watchMask = mask & infoPtr->validMask;
+ if (infoPtr->watchMask) {
+ Tcl_SetMaxBlockTime(&blockTime);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FileGetHandleProc --
+ *
+ * Called from Tcl_GetChannelFile to retrieve OS handles from
+ * a file based channel.
+ *
+ * Results:
+ * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if
+ * there is no handle for the specified direction.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+FileGetHandleProc(instanceData, direction, handlePtr)
+ ClientData instanceData; /* The file state. */
+ int direction; /* TCL_READABLE or TCL_WRITABLE */
+ ClientData *handlePtr; /* Where to store the handle. */
+{
+ FileInfo *infoPtr = (FileInfo *) instanceData;
+
+ if (direction & infoPtr->validMask) {
+ *handlePtr = (ClientData) infoPtr->handle;
+ return TCL_OK;
+ } else {
+ return TCL_ERROR;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ComInputProc --
+ *
+ * Reads input from the IO channel into the buffer given. Returns
+ * count of how many bytes were actually read, and an error indication.
+ *
+ * Results:
+ * A count of how many bytes were read is returned and an error
+ * indication is returned in an output argument.
+ *
+ * Side effects:
+ * Reads input from the actual channel.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ComInputProc(instanceData, buf, bufSize, errorCode)
+ ClientData instanceData; /* File state. */
+ char *buf; /* Where to store data read. */
+ int bufSize; /* How much space is available
+ * in the buffer? */
+ int *errorCode; /* Where to store error code. */
+{
+ FileInfo *infoPtr;
+ DWORD bytesRead;
+ DWORD dw;
+ COMSTAT cs;
+
+ *errorCode = 0;
+ infoPtr = (FileInfo *) instanceData;
+
+ if (ClearCommError(infoPtr->handle, &dw, &cs)) {
+ if (dw != 0) {
+ *errorCode = EIO;
+ return -1;
+ }
+ if (cs.cbInQue != 0) {
+ if ((DWORD) bufSize > cs.cbInQue) {
+ bufSize = cs.cbInQue;
+ }
+ } else {
+ if (infoPtr->flags & FILE_ASYNC) {
+ errno = *errorCode = EAGAIN;
+ return -1;
+ } else {
+ bufSize = 1;
+ }
+ }
+ }
+
+ if (ReadFile(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize, &bytesRead,
+ (LPOVERLAPPED) NULL) == FALSE) {
+ TclWinConvertError(GetLastError());
+ *errorCode = errno;
+ return -1;
+ }
+
+ return bytesRead;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ComSetOptionProc --
+ *
+ * Sets an option on a channel.
+ *
+ * Results:
+ * A standard Tcl result. Also sets interp->result on error if
+ * interp is not NULL.
+ *
+ * Side effects:
+ * May modify an option on a device.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ComSetOptionProc(instanceData, interp, optionName, value)
+ ClientData instanceData; /* File state. */
+ Tcl_Interp *interp; /* For error reporting - can be NULL. */
+ char *optionName; /* Which option to set? */
+ char *value; /* New value for option. */
+{
+ FileInfo *infoPtr;
+ DCB dcb;
+ int len;
+
+ infoPtr = (FileInfo *) instanceData;
+
+ len = strlen(optionName);
+ if ((len > 1) && (strncmp(optionName, "-mode", len) == 0)) {
+ if (GetCommState(infoPtr->handle, &dcb)) {
+ if ((BuildCommDCB(value, &dcb) == FALSE) ||
+ (SetCommState(infoPtr->handle, &dcb) == FALSE)) {
+ /*
+ * one should separate the 2 errors...
+ */
+ if (interp) {
+ Tcl_AppendResult(interp, "bad value for -mode: should be ",
+ "baud,parity,data,stop", NULL);
+ }
+ return TCL_ERROR;
+ } else {
+ return TCL_OK;
+ }
+ } else {
+ if (interp) {
+ Tcl_AppendResult(interp, "can't get comm state", NULL);
+ }
+ return TCL_ERROR;
+ }
+ } else {
+ return Tcl_BadChannelOption(interp, optionName, "mode");
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ComGetOptionProc --
+ *
+ * Gets a mode associated with an IO channel. If the optionName arg
+ * is non NULL, retrieves the value of that option. If the optionName
+ * arg is NULL, retrieves a list of alternating option names and
+ * values for the given channel.
+ *
+ * Results:
+ * A standard Tcl result. Also sets the supplied DString to the
+ * string value of the option(s) returned.
+ *
+ * Side effects:
+ * The string returned by this function is in static storage and
+ * may be reused at any time subsequent to the call.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ComGetOptionProc(instanceData, interp, optionName, dsPtr)
+ ClientData instanceData; /* File state. */
+ Tcl_Interp *interp; /* For error reporting - can be NULL. */
+ char *optionName; /* Option to get. */
+ Tcl_DString *dsPtr; /* Where to store value(s). */
+{
+ FileInfo *infoPtr;
+ DCB dcb;
+ int len;
+
+ infoPtr = (FileInfo *) instanceData;
+
+ if (optionName == NULL) {
+ Tcl_DStringAppendElement(dsPtr, "-mode");
+ len = 0;
+ } else {
+ len = strlen(optionName);
+ }
+ if ((len == 0) ||
+ ((len > 1) && (strncmp(optionName, "-mode", len) == 0))) {
+ if (GetCommState(infoPtr->handle, &dcb) == 0) {
+ /*
+ * shouldn't we flag an error instead ?
+ */
+ Tcl_DStringAppendElement(dsPtr, "");
+ } else {
+ char parity;
+ char *stop;
+ char buf[32];
+
+ parity = 'n';
+ if (dcb.Parity < 4) {
+ parity = "noems"[dcb.Parity];
+ }
+
+ stop = (dcb.StopBits == ONESTOPBIT) ? "1" :
+ (dcb.StopBits == ONE5STOPBITS) ? "1.5" : "2";
+
+ wsprintf(buf, "%d,%c,%d,%s", dcb.BaudRate, parity, dcb.ByteSize,
+ stop);
+ Tcl_DStringAppendElement(dsPtr, buf);
+ }
+ return TCL_OK;
+ } else {
+ return Tcl_BadChannelOption(interp, optionName, "mode");
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_OpenFileChannel --
+ *
+ * Open an File based channel on Unix systems.
+ *
+ * Results:
+ * The new channel or NULL. If NULL, the output argument
+ * errorCodePtr is set to a POSIX error.
+ *
+ * Side effects:
+ * May open the channel and may cause creation of a file on the
+ * file system.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Channel
+Tcl_OpenFileChannel(interp, fileName, modeString, permissions)
+ Tcl_Interp *interp; /* Interpreter for error reporting;
+ * can be NULL. */
+ char *fileName; /* Name of file to open. */
+ char *modeString; /* A list of POSIX open modes or
+ * a string such as "rw". */
+ int permissions; /* If the open involves creating a
+ * file, with what modes to create
+ * it? */
+{
+ FileInfo *infoPtr;
+ int seekFlag, mode, channelPermissions;
+ DWORD accessMode, createMode, shareMode, flags;
+ char *nativeName;
+ Tcl_DString buffer;
+ DCB dcb;
+ Tcl_ChannelType *channelTypePtr;
+ HANDLE handle;
+
+ if (!initialized) {
+ FileInit();
+ }
+
+ mode = TclGetOpenMode(interp, modeString, &seekFlag);
+ if (mode == -1) {
+ return NULL;
+ }
+
+ nativeName = Tcl_TranslateFileName(interp, fileName, &buffer);
+ if (nativeName == NULL) {
+ return NULL;
+ }
+
+ switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
+ case O_RDONLY:
+ accessMode = GENERIC_READ;
+ channelPermissions = TCL_READABLE;
+ break;
+ case O_WRONLY:
+ accessMode = GENERIC_WRITE;
+ channelPermissions = TCL_WRITABLE;
+ break;
+ case O_RDWR:
+ accessMode = (GENERIC_READ | GENERIC_WRITE);
+ channelPermissions = (TCL_READABLE | TCL_WRITABLE);
+ break;
+ default:
+ panic("Tcl_OpenFileChannel: invalid mode value");
+ break;
+ }
+
+ /*
+ * Map the creation flags to the NT create mode.
+ */
+
+ switch (mode & (O_CREAT | O_EXCL | O_TRUNC)) {
+ case (O_CREAT | O_EXCL):
+ case (O_CREAT | O_EXCL | O_TRUNC):
+ createMode = CREATE_NEW;
+ break;
+ case (O_CREAT | O_TRUNC):
+ createMode = CREATE_ALWAYS;
+ break;
+ case O_CREAT:
+ createMode = OPEN_ALWAYS;
+ break;
+ case O_TRUNC:
+ case (O_TRUNC | O_EXCL):
+ createMode = TRUNCATE_EXISTING;
+ break;
+ default:
+ createMode = OPEN_EXISTING;
+ break;
+ }
+
+ /*
+ * If the file is being created, get the file attributes from the
+ * permissions argument, else use the existing file attributes.
+ */
+
+ if (mode & O_CREAT) {
+ if (permissions & S_IWRITE) {
+ flags = FILE_ATTRIBUTE_NORMAL;
+ } else {
+ flags = FILE_ATTRIBUTE_READONLY;
+ }
+ } else {
+ flags = GetFileAttributes(nativeName);
+ if (flags == 0xFFFFFFFF) {
+ flags = 0;
+ }
+ }
+
+ /*
+ * Set up the file sharing mode. We want to allow simultaneous access.
+ */
+
+ shareMode = FILE_SHARE_READ | FILE_SHARE_WRITE;
+
+ /*
+ * Now we get to create the file.
+ */
+
+ handle = CreateFile(nativeName, accessMode, shareMode, NULL, createMode,
+ flags, (HANDLE) NULL);
+
+ if (handle == INVALID_HANDLE_VALUE) {
+ DWORD err;
+
+ openerr:
+ err = GetLastError();
+ if ((err & 0xffffL) == ERROR_OPEN_FAILED) {
+ err = (mode & O_CREAT) ? ERROR_FILE_EXISTS : ERROR_FILE_NOT_FOUND;
+ }
+ TclWinConvertError(err);
+ if (interp != (Tcl_Interp *) NULL) {
+ Tcl_AppendResult(interp, "couldn't open \"", fileName, "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
+ }
+ Tcl_DStringFree(&buffer);
+ return NULL;
+ }
+
+ if (GetFileType(handle) == FILE_TYPE_CHAR) {
+ dcb.DCBlength = sizeof( DCB ) ;
+ if (GetCommState(handle, &dcb)) {
+ /*
+ * This is a com port. Reopen it with the correct modes.
+ */
+
+ COMMTIMEOUTS cto;
+
+ CloseHandle(handle);
+ handle = CreateFile(nativeName, accessMode, 0, NULL, OPEN_EXISTING,
+ flags, NULL);
+ if (handle == INVALID_HANDLE_VALUE) {
+ goto openerr;
+ }
+
+ /*
+ * FileInit the com port.
+ */
+
+ SetCommMask(handle, EV_RXCHAR);
+ SetupComm(handle, 4096, 4096);
+ PurgeComm(handle, PURGE_TXABORT | PURGE_RXABORT | PURGE_TXCLEAR
+ | PURGE_RXCLEAR);
+ cto.ReadIntervalTimeout = MAXDWORD;
+ cto.ReadTotalTimeoutMultiplier = 0;
+ cto.ReadTotalTimeoutConstant = 0;
+ cto.WriteTotalTimeoutMultiplier = 0;
+ cto.WriteTotalTimeoutConstant = 0;
+ SetCommTimeouts(handle, &cto);
+
+ GetCommState(handle, &dcb);
+ SetCommState(handle, &dcb);
+ channelTypePtr = &comChannelType;
+ } else {
+ channelTypePtr = &fileChannelType;
+ }
+ } else {
+ channelTypePtr = &fileChannelType;
+ }
+ Tcl_DStringFree(&buffer);
+
+ infoPtr = (FileInfo *) ckalloc((unsigned) sizeof(FileInfo));
+ infoPtr->nextPtr = firstFilePtr;
+ firstFilePtr = infoPtr;
+ infoPtr->validMask = channelPermissions;
+ infoPtr->watchMask = 0;
+ infoPtr->flags = (mode & O_APPEND) ? FILE_APPEND : 0;
+ infoPtr->handle = handle;
+
+ sprintf(channelName, "file%d", (int) handle);
+
+ infoPtr->channel = Tcl_CreateChannel(channelTypePtr, channelName,
+ (ClientData) infoPtr, channelPermissions);
+
+ if (seekFlag) {
+ if (Tcl_Seek(infoPtr->channel, 0, SEEK_END) < 0) {
+ if (interp != (Tcl_Interp *) NULL) {
+ Tcl_AppendResult(interp, "could not seek to end of file on \"",
+ channelName, "\": ", Tcl_PosixError(interp),
+ (char *) NULL);
+ }
+ Tcl_Close(NULL, infoPtr->channel);
+ return NULL;
+ }
+ }
+
+ /*
+ * Files have default translation of AUTO and ^Z eof char, which
+ * means that a ^Z will be appended to them at close.
+ */
+
+ Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");
+ Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}");
+ return infoPtr->channel;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_MakeFileChannel --
+ *
+ * Creates a Tcl_Channel from an existing platform specific file
+ * handle.
+ *
+ * Results:
+ * The Tcl_Channel created around the preexisting file.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Channel
+Tcl_MakeFileChannel(handle, mode)
+ ClientData handle; /* OS level handle */
+ int mode; /* ORed combination of TCL_READABLE and
+ * TCL_WRITABLE to indicate file mode. */
+{
+ char channelName[20];
+ FileInfo *infoPtr;
+
+ if (!initialized) {
+ FileInit();
+ }
+
+ if (mode == 0) {
+ return NULL;
+ }
+
+ sprintf(channelName, "file%d", (int) handle);
+
+ /*
+ * See if a channel with this handle already exists.
+ */
+
+ for (infoPtr = firstFilePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
+ if (infoPtr->handle == (HANDLE) handle) {
+ return (mode == infoPtr->validMask) ? infoPtr->channel : NULL;
+ }
+ }
+
+ infoPtr = (FileInfo *) ckalloc((unsigned) sizeof(FileInfo));
+ infoPtr->nextPtr = firstFilePtr;
+ firstFilePtr = infoPtr;
+ infoPtr->validMask = mode;
+ infoPtr->watchMask = 0;
+ infoPtr->flags = 0;
+ infoPtr->handle = (HANDLE) handle;
+ infoPtr->channel = Tcl_CreateChannel(&fileChannelType, channelName,
+ (ClientData) infoPtr, mode);
+
+ /*
+ * Windows files have AUTO translation mode and ^Z eof char on input.
+ */
+
+ Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");
+ Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}");
+ return infoPtr->channel;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclGetDefaultStdChannel --
+ *
+ * Constructs a channel for the specified standard OS handle.
+ *
+ * Results:
+ * Returns the specified default standard channel, or NULL.
+ *
+ * Side effects:
+ * May cause the creation of a standard channel and the underlying
+ * file.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Channel
+TclGetDefaultStdChannel(type)
+ int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */
+{
+ Tcl_Channel channel;
+ HANDLE handle;
+ int mode;
+ char *bufMode;
+ DWORD handleId; /* Standard handle to retrieve. */
+
+ switch (type) {
+ case TCL_STDIN:
+ handleId = STD_INPUT_HANDLE;
+ mode = TCL_READABLE;
+ bufMode = "line";
+ break;
+ case TCL_STDOUT:
+ handleId = STD_OUTPUT_HANDLE;
+ mode = TCL_WRITABLE;
+ bufMode = "line";
+ break;
+ case TCL_STDERR:
+ handleId = STD_ERROR_HANDLE;
+ mode = TCL_WRITABLE;
+ bufMode = "none";
+ break;
+ default:
+ panic("TclGetDefaultStdChannel: Unexpected channel type");
+ break;
+ }
+ handle = GetStdHandle(handleId);
+
+ /*
+ * Note that we need to check for 0 because Windows will return 0 if this
+ * is not a console mode application, even though this is not a valid
+ * handle.
+ */
+
+ if ((handle == INVALID_HANDLE_VALUE) || (handle == 0)) {
+ return NULL;
+ }
+
+ channel = Tcl_MakeFileChannel(handle, mode);
+
+ /*
+ * Set up the normal channel options for stdio handles.
+ */
+
+ if ((Tcl_SetChannelOption((Tcl_Interp *) NULL, channel, "-translation",
+ "auto") == TCL_ERROR)
+ || (Tcl_SetChannelOption((Tcl_Interp *) NULL, channel, "-eofchar",
+ "\032 {}") == TCL_ERROR)
+ || (Tcl_SetChannelOption((Tcl_Interp *) NULL, channel,
+ "-buffering", bufMode) == TCL_ERROR)) {
+ Tcl_Close((Tcl_Interp *) NULL, channel);
+ return (Tcl_Channel) NULL;
+ }
+ return channel;
+}
diff --git a/win/tclWinError.c b/win/tclWinError.c
new file mode 100644
index 0000000..5361174
--- /dev/null
+++ b/win/tclWinError.c
@@ -0,0 +1,393 @@
+/*
+ * tclWinError.c --
+ *
+ * This file contains code for converting from Win32 errors to
+ * errno errors.
+ *
+ * Copyright (c) 1995-1996 by Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclWinError.c 1.7 97/10/28 17:30:33
+ */
+
+#include "tclInt.h"
+#include "tclPort.h"
+
+/*
+ * The following table contains the mapping from Win32 errors to
+ * errno errors.
+ */
+
+static char errorTable[] = {
+ 0,
+ EINVAL, /* ERROR_INVALID_FUNCTION 1 */
+ ENOENT, /* ERROR_FILE_NOT_FOUND 2 */
+ ENOENT, /* ERROR_PATH_NOT_FOUND 3 */
+ EMFILE, /* ERROR_TOO_MANY_OPEN_FILES 4 */
+ EACCES, /* ERROR_ACCESS_DENIED 5 */
+ EBADF, /* ERROR_INVALID_HANDLE 6 */
+ ENOMEM, /* ERROR_ARENA_TRASHED 7 */
+ ENOMEM, /* ERROR_NOT_ENOUGH_MEMORY 8 */
+ ENOMEM, /* ERROR_INVALID_BLOCK 9 */
+ E2BIG, /* ERROR_BAD_ENVIRONMENT 10 */
+ ENOEXEC, /* ERROR_BAD_FORMAT 11 */
+ EACCES, /* ERROR_INVALID_ACCESS 12 */
+ EINVAL, /* ERROR_INVALID_DATA 13 */
+ EFAULT, /* ERROR_OUT_OF_MEMORY 14 */
+ ENOENT, /* ERROR_INVALID_DRIVE 15 */
+ EACCES, /* ERROR_CURRENT_DIRECTORY 16 */
+ EXDEV, /* ERROR_NOT_SAME_DEVICE 17 */
+ ENOENT, /* ERROR_NO_MORE_FILES 18 */
+ EROFS, /* ERROR_WRITE_PROTECT 19 */
+ ENXIO, /* ERROR_BAD_UNIT 20 */
+ EBUSY, /* ERROR_NOT_READY 21 */
+ EIO, /* ERROR_BAD_COMMAND 22 */
+ EIO, /* ERROR_CRC 23 */
+ EIO, /* ERROR_BAD_LENGTH 24 */
+ EIO, /* ERROR_SEEK 25 */
+ EIO, /* ERROR_NOT_DOS_DISK 26 */
+ ENXIO, /* ERROR_SECTOR_NOT_FOUND 27 */
+ EBUSY, /* ERROR_OUT_OF_PAPER 28 */
+ EIO, /* ERROR_WRITE_FAULT 29 */
+ EIO, /* ERROR_READ_FAULT 30 */
+ EIO, /* ERROR_GEN_FAILURE 31 */
+ EACCES, /* ERROR_SHARING_VIOLATION 32 */
+ EACCES, /* ERROR_LOCK_VIOLATION 33 */
+ ENXIO, /* ERROR_WRONG_DISK 34 */
+ ENFILE, /* ERROR_FCB_UNAVAILABLE 35 */
+ ENFILE, /* ERROR_SHARING_BUFFER_EXCEEDED 36 */
+ EINVAL, /* 37 */
+ EINVAL, /* 38 */
+ ENOSPC, /* ERROR_HANDLE_DISK_FULL 39 */
+ EINVAL, /* 40 */
+ EINVAL, /* 41 */
+ EINVAL, /* 42 */
+ EINVAL, /* 43 */
+ EINVAL, /* 44 */
+ EINVAL, /* 45 */
+ EINVAL, /* 46 */
+ EINVAL, /* 47 */
+ EINVAL, /* 48 */
+ EINVAL, /* 49 */
+ ENODEV, /* ERROR_NOT_SUPPORTED 50 */
+ EBUSY, /* ERROR_REM_NOT_LIST 51 */
+ EEXIST, /* ERROR_DUP_NAME 52 */
+ ENOENT, /* ERROR_BAD_NETPATH 53 */
+ EBUSY, /* ERROR_NETWORK_BUSY 54 */
+ ENODEV, /* ERROR_DEV_NOT_EXIST 55 */
+ EAGAIN, /* ERROR_TOO_MANY_CMDS 56 */
+ EIO, /* ERROR_ADAP_HDW_ERR 57 */
+ EIO, /* ERROR_BAD_NET_RESP 58 */
+ EIO, /* ERROR_UNEXP_NET_ERR 59 */
+ EINVAL, /* ERROR_BAD_REM_ADAP 60 */
+ EFBIG, /* ERROR_PRINTQ_FULL 61 */
+ ENOSPC, /* ERROR_NO_SPOOL_SPACE 62 */
+ ENOENT, /* ERROR_PRINT_CANCELLED 63 */
+ ENOENT, /* ERROR_NETNAME_DELETED 64 */
+ EACCES, /* ERROR_NETWORK_ACCESS_DENIED 65 */
+ ENODEV, /* ERROR_BAD_DEV_TYPE 66 */
+ ENOENT, /* ERROR_BAD_NET_NAME 67 */
+ ENFILE, /* ERROR_TOO_MANY_NAMES 68 */
+ EIO, /* ERROR_TOO_MANY_SESS 69 */
+ EAGAIN, /* ERROR_SHARING_PAUSED 70 */
+ EINVAL, /* ERROR_REQ_NOT_ACCEP 71 */
+ EAGAIN, /* ERROR_REDIR_PAUSED 72 */
+ EINVAL, /* 73 */
+ EINVAL, /* 74 */
+ EINVAL, /* 75 */
+ EINVAL, /* 76 */
+ EINVAL, /* 77 */
+ EINVAL, /* 78 */
+ EINVAL, /* 79 */
+ EEXIST, /* ERROR_FILE_EXISTS 80 */
+ EINVAL, /* 81 */
+ ENOSPC, /* ERROR_CANNOT_MAKE 82 */
+ EIO, /* ERROR_FAIL_I24 83 */
+ ENFILE, /* ERROR_OUT_OF_STRUCTURES 84 */
+ EEXIST, /* ERROR_ALREADY_ASSIGNED 85 */
+ EPERM, /* ERROR_INVALID_PASSWORD 86 */
+ EINVAL, /* ERROR_INVALID_PARAMETER 87 */
+ EIO, /* ERROR_NET_WRITE_FAULT 88 */
+ EAGAIN, /* ERROR_NO_PROC_SLOTS 89 */
+ EINVAL, /* 90 */
+ EINVAL, /* 91 */
+ EINVAL, /* 92 */
+ EINVAL, /* 93 */
+ EINVAL, /* 94 */
+ EINVAL, /* 95 */
+ EINVAL, /* 96 */
+ EINVAL, /* 97 */
+ EINVAL, /* 98 */
+ EINVAL, /* 99 */
+ EINVAL, /* 100 */
+ EINVAL, /* 101 */
+ EINVAL, /* 102 */
+ EINVAL, /* 103 */
+ EINVAL, /* 104 */
+ EINVAL, /* 105 */
+ EINVAL, /* 106 */
+ EXDEV, /* ERROR_DISK_CHANGE 107 */
+ EAGAIN, /* ERROR_DRIVE_LOCKED 108 */
+ EPIPE, /* ERROR_BROKEN_PIPE 109 */
+ ENOENT, /* ERROR_OPEN_FAILED 110 */
+ EINVAL, /* ERROR_BUFFER_OVERFLOW 111 */
+ ENOSPC, /* ERROR_DISK_FULL 112 */
+ EMFILE, /* ERROR_NO_MORE_SEARCH_HANDLES 113 */
+ EBADF, /* ERROR_INVALID_TARGET_HANDLE 114 */
+ EFAULT, /* ERROR_PROTECTION_VIOLATION 115 */
+ EINVAL, /* 116 */
+ EINVAL, /* 117 */
+ EINVAL, /* 118 */
+ EINVAL, /* 119 */
+ EINVAL, /* 120 */
+ EINVAL, /* 121 */
+ EINVAL, /* 122 */
+ ENOENT, /* ERROR_INVALID_NAME 123 */
+ EINVAL, /* 124 */
+ EINVAL, /* 125 */
+ EINVAL, /* 126 */
+ ESRCH, /* ERROR_PROC_NOT_FOUND 127 */
+ ECHILD, /* ERROR_WAIT_NO_CHILDREN 128 */
+ ECHILD, /* ERROR_CHILD_NOT_COMPLETE 129 */
+ EBADF, /* ERROR_DIRECT_ACCESS_HANDLE 130 */
+ EINVAL, /* 131 */
+ ESPIPE, /* ERROR_SEEK_ON_DEVICE 132 */
+ EINVAL, /* 133 */
+ EINVAL, /* 134 */
+ EINVAL, /* 135 */
+ EINVAL, /* 136 */
+ EINVAL, /* 137 */
+ EINVAL, /* 138 */
+ EINVAL, /* 139 */
+ EINVAL, /* 140 */
+ EINVAL, /* 141 */
+ EAGAIN, /* ERROR_BUSY_DRIVE 142 */
+ EINVAL, /* 143 */
+ EINVAL, /* 144 */
+ EEXIST, /* ERROR_DIR_NOT_EMPTY 145 */
+ EINVAL, /* 146 */
+ EINVAL, /* 147 */
+ EINVAL, /* 148 */
+ EINVAL, /* 149 */
+ EINVAL, /* 150 */
+ EINVAL, /* 151 */
+ EINVAL, /* 152 */
+ EINVAL, /* 153 */
+ EINVAL, /* 154 */
+ EINVAL, /* 155 */
+ EINVAL, /* 156 */
+ EINVAL, /* 157 */
+ EACCES, /* ERROR_NOT_LOCKED 158 */
+ EINVAL, /* 159 */
+ EINVAL, /* 160 */
+ ENOENT, /* ERROR_BAD_PATHNAME 161 */
+ EINVAL, /* 162 */
+ EINVAL, /* 163 */
+ EINVAL, /* 164 */
+ EINVAL, /* 165 */
+ EINVAL, /* 166 */
+ EACCES, /* ERROR_LOCK_FAILED 167 */
+ EINVAL, /* 168 */
+ EINVAL, /* 169 */
+ EINVAL, /* 170 */
+ EINVAL, /* 171 */
+ EINVAL, /* 172 */
+ EINVAL, /* 173 */
+ EINVAL, /* 174 */
+ EINVAL, /* 175 */
+ EINVAL, /* 176 */
+ EINVAL, /* 177 */
+ EINVAL, /* 178 */
+ EINVAL, /* 179 */
+ EINVAL, /* 180 */
+ EINVAL, /* 181 */
+ EINVAL, /* 182 */
+ EEXIST, /* ERROR_ALREADY_EXISTS 183 */
+ ECHILD, /* ERROR_NO_CHILD_PROCESS 184 */
+ EINVAL, /* 185 */
+ EINVAL, /* 186 */
+ EINVAL, /* 187 */
+ EINVAL, /* 188 */
+ EINVAL, /* 189 */
+ EINVAL, /* 190 */
+ EINVAL, /* 191 */
+ EINVAL, /* 192 */
+ EINVAL, /* 193 */
+ EINVAL, /* 194 */
+ EINVAL, /* 195 */
+ EINVAL, /* 196 */
+ EINVAL, /* 197 */
+ EINVAL, /* 198 */
+ EINVAL, /* 199 */
+ EINVAL, /* 200 */
+ EINVAL, /* 201 */
+ EINVAL, /* 202 */
+ EINVAL, /* 203 */
+ EINVAL, /* 204 */
+ EINVAL, /* 205 */
+ ENAMETOOLONG,/* ERROR_FILENAME_EXCED_RANGE 206 */
+ EINVAL, /* 207 */
+ EINVAL, /* 208 */
+ EINVAL, /* 209 */
+ EINVAL, /* 210 */
+ EINVAL, /* 211 */
+ EINVAL, /* 212 */
+ EINVAL, /* 213 */
+ EINVAL, /* 214 */
+ EINVAL, /* 215 */
+ EINVAL, /* 216 */
+ EINVAL, /* 217 */
+ EINVAL, /* 218 */
+ EINVAL, /* 219 */
+ EINVAL, /* 220 */
+ EINVAL, /* 221 */
+ EINVAL, /* 222 */
+ EINVAL, /* 223 */
+ EINVAL, /* 224 */
+ EINVAL, /* 225 */
+ EINVAL, /* 226 */
+ EINVAL, /* 227 */
+ EINVAL, /* 228 */
+ EINVAL, /* 229 */
+ EPIPE, /* ERROR_BAD_PIPE 230 */
+ EAGAIN, /* ERROR_PIPE_BUSY 231 */
+ EPIPE, /* ERROR_NO_DATA 232 */
+ EPIPE, /* ERROR_PIPE_NOT_CONNECTED 233 */
+ EINVAL, /* 234 */
+ EINVAL, /* 235 */
+ EINVAL, /* 236 */
+ EINVAL, /* 237 */
+ EINVAL, /* 238 */
+ EINVAL, /* 239 */
+ EINVAL, /* 240 */
+ EINVAL, /* 241 */
+ EINVAL, /* 242 */
+ EINVAL, /* 243 */
+ EINVAL, /* 244 */
+ EINVAL, /* 245 */
+ EINVAL, /* 246 */
+ EINVAL, /* 247 */
+ EINVAL, /* 248 */
+ EINVAL, /* 249 */
+ EINVAL, /* 250 */
+ EINVAL, /* 251 */
+ EINVAL, /* 252 */
+ EINVAL, /* 253 */
+ EINVAL, /* 254 */
+ EINVAL, /* 255 */
+ EINVAL, /* 256 */
+ EINVAL, /* 257 */
+ EINVAL, /* 258 */
+ EINVAL, /* 259 */
+ EINVAL, /* 260 */
+ EINVAL, /* 261 */
+ EINVAL, /* 262 */
+ EINVAL, /* 263 */
+ EINVAL, /* 264 */
+ EINVAL, /* 265 */
+ EINVAL, /* 266 */
+ ENOTDIR, /* ERROR_DIRECTORY 267 */
+};
+
+static const unsigned int tableLen = sizeof(errorTable);
+
+/*
+ * The following table contains the mapping from WinSock errors to
+ * errno errors.
+ */
+
+static int wsaErrorTable[] = {
+ EWOULDBLOCK, /* WSAEWOULDBLOCK */
+ EINPROGRESS, /* WSAEINPROGRESS */
+ EALREADY, /* WSAEALREADY */
+ ENOTSOCK, /* WSAENOTSOCK */
+ EDESTADDRREQ, /* WSAEDESTADDRREQ */
+ EMSGSIZE, /* WSAEMSGSIZE */
+ EPROTOTYPE, /* WSAEPROTOTYPE */
+ ENOPROTOOPT, /* WSAENOPROTOOPT */
+ EPROTONOSUPPORT, /* WSAEPROTONOSUPPORT */
+ ESOCKTNOSUPPORT, /* WSAESOCKTNOSUPPORT */
+ EOPNOTSUPP, /* WSAEOPNOTSUPP */
+ EPFNOSUPPORT, /* WSAEPFNOSUPPORT */
+ EAFNOSUPPORT, /* WSAEAFNOSUPPORT */
+ EADDRINUSE, /* WSAEADDRINUSE */
+ EADDRNOTAVAIL, /* WSAEADDRNOTAVAIL */
+ ENETDOWN, /* WSAENETDOWN */
+ ENETUNREACH, /* WSAENETUNREACH */
+ ENETRESET, /* WSAENETRESET */
+ ECONNABORTED, /* WSAECONNABORTED */
+ ECONNRESET, /* WSAECONNRESET */
+ ENOBUFS, /* WSAENOBUFS */
+ EISCONN, /* WSAEISCONN */
+ ENOTCONN, /* WSAENOTCONN */
+ ESHUTDOWN, /* WSAESHUTDOWN */
+ ETOOMANYREFS, /* WSAETOOMANYREFS */
+ ETIMEDOUT, /* WSAETIMEDOUT */
+ ECONNREFUSED, /* WSAECONNREFUSED */
+ ELOOP, /* WSAELOOP */
+ ENAMETOOLONG, /* WSAENAMETOOLONG */
+ EHOSTDOWN, /* WSAEHOSTDOWN */
+ EHOSTUNREACH, /* WSAEHOSTUNREACH */
+ ENOTEMPTY, /* WSAENOTEMPTY */
+ EAGAIN, /* WSAEPROCLIM */
+ EUSERS, /* WSAEUSERS */
+ EDQUOT, /* WSAEDQUOT */
+ ESTALE, /* WSAESTALE */
+ EREMOTE, /* WSAEREMOTE */
+};
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclWinConvertError --
+ *
+ * This routine converts a Win32 error into an errno value.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Sets the errno global variable.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclWinConvertError(errCode)
+ DWORD errCode; /* Win32 error code. */
+{
+ if (errCode >= tableLen) {
+ Tcl_SetErrno(EINVAL);
+ } else {
+ Tcl_SetErrno(errorTable[errCode]);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclWinConvertWSAError --
+ *
+ * This routine converts a WinSock error into an errno value.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Sets the errno global variable.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclWinConvertWSAError(errCode)
+ DWORD errCode; /* Win32 error code. */
+{
+ if ((errCode >= WSAEWOULDBLOCK) && (errCode <= WSAEREMOTE)) {
+ Tcl_SetErrno(wsaErrorTable[errCode - WSAEWOULDBLOCK]);
+ } else {
+ Tcl_SetErrno(EINVAL);
+ }
+}
diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c
new file mode 100644
index 0000000..f2df779
--- /dev/null
+++ b/win/tclWinFCmd.c
@@ -0,0 +1,1401 @@
+/*
+ * tclWinFCmd.c
+ *
+ * This file implements the Windows specific portion of file manipulation
+ * subcommands of the "file" command.
+ *
+ * Copyright (c) 1996-1997 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclWinFCmd.c 1.20 97/10/10 11:50:14
+ */
+
+#include "tclWinInt.h"
+
+/*
+ * The following constants specify the type of callback when
+ * TraverseWinTree() calls the traverseProc()
+ */
+
+#define DOTREE_PRED 1 /* pre-order directory */
+#define DOTREE_POSTD 2 /* post-order directory */
+#define DOTREE_F 3 /* regular file */
+
+/*
+ * Callbacks for file attributes code.
+ */
+
+static int GetWinFileAttributes _ANSI_ARGS_((Tcl_Interp *interp,
+ int objIndex, char *fileName,
+ Tcl_Obj **attributePtrPtr));
+static int GetWinFileLongName _ANSI_ARGS_((Tcl_Interp *interp,
+ int objIndex, char *fileName,
+ Tcl_Obj **attributePtrPtr));
+static int GetWinFileShortName _ANSI_ARGS_((Tcl_Interp *interp,
+ int objIndex, char *fileName,
+ Tcl_Obj **attributePtrPtr));
+static int SetWinFileAttributes _ANSI_ARGS_((Tcl_Interp *interp,
+ int objIndex, char *fileName,
+ Tcl_Obj *attributePtr));
+static int CannotSetAttribute _ANSI_ARGS_((Tcl_Interp *interp,
+ int objIndex, char *fileName,
+ Tcl_Obj *attributePtr));
+
+/*
+ * Constants and variables necessary for file attributes subcommand.
+ */
+
+enum {
+ WIN_ARCHIVE_ATTRIBUTE,
+ WIN_HIDDEN_ATTRIBUTE,
+ WIN_LONGNAME_ATTRIBUTE,
+ WIN_READONLY_ATTRIBUTE,
+ WIN_SHORTNAME_ATTRIBUTE,
+ WIN_SYSTEM_ATTRIBUTE
+};
+
+static int attributeArray[] = {FILE_ATTRIBUTE_ARCHIVE, FILE_ATTRIBUTE_HIDDEN,
+ 0, FILE_ATTRIBUTE_READONLY, 0, FILE_ATTRIBUTE_SYSTEM};
+
+
+char *tclpFileAttrStrings[] = {"-archive", "-hidden", "-longname", "-readonly",
+ "-shortname", "-system", (char *) NULL};
+CONST TclFileAttrProcs tclpFileAttrProcs[] = {
+ {GetWinFileAttributes, SetWinFileAttributes},
+ {GetWinFileAttributes, SetWinFileAttributes},
+ {GetWinFileLongName, CannotSetAttribute},
+ {GetWinFileAttributes, SetWinFileAttributes},
+ {GetWinFileShortName, CannotSetAttribute},
+ {GetWinFileAttributes, SetWinFileAttributes}};
+
+/*
+ * Prototype for the TraverseWinTree callback function.
+ */
+
+typedef int (TraversalProc)(char *src, char *dst, DWORD attr, int type,
+ Tcl_DString *errorPtr);
+
+/*
+ * Declarations for local procedures defined in this file:
+ */
+
+static void AttributesPosixError _ANSI_ARGS_((Tcl_Interp *interp,
+ int objIndex, char *fileName, int getOrSet));
+static int ConvertFileNameFormat _ANSI_ARGS_((Tcl_Interp *interp,
+ int objIndex, char *fileName, int longShort,
+ Tcl_Obj **attributePtrPtr));
+static int TraversalCopy(char *src, char *dst, DWORD attr,
+ int type, Tcl_DString *errorPtr);
+static int TraversalDelete(char *src, char *dst, DWORD attr,
+ int type, Tcl_DString *errorPtr);
+static int TraverseWinTree(TraversalProc *traverseProc,
+ Tcl_DString *sourcePtr, Tcl_DString *destPtr,
+ Tcl_DString *errorPtr);
+
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclpRenameFile --
+ *
+ * Changes the name of an existing file or directory, from src to dst.
+ * If src and dst refer to the same file or directory, does nothing
+ * and returns success. Otherwise if dst already exists, it will be
+ * deleted and replaced by src subject to the following conditions:
+ * If src is a directory, dst may be an empty directory.
+ * If src is a file, dst may be a file.
+ * In any other situation where dst already exists, the rename will
+ * fail.
+ *
+ * Results:
+ * If the directory was successfully created, returns TCL_OK.
+ * Otherwise the return value is TCL_ERROR and errno is set to
+ * indicate the error. Some possible values for errno are:
+ *
+ * EACCES: src or dst parent directory can't be read and/or written.
+ * EEXIST: dst is a non-empty directory.
+ * EINVAL: src is a root directory or dst is a subdirectory of src.
+ * EISDIR: dst is a directory, but src is not.
+ * ENOENT: src doesn't exist. src or dst is "".
+ * ENOTDIR: src is a directory, but dst is not.
+ * EXDEV: src and dst are on different filesystems.
+ *
+ * EACCES: exists an open file already referring to src or dst.
+ * EACCES: src or dst specify the current working directory (NT).
+ * EACCES: src specifies a char device (nul:, com1:, etc.)
+ * EEXIST: dst specifies a char device (nul:, com1:, etc.) (NT)
+ * EACCES: dst specifies a char device (nul:, com1:, etc.) (95)
+ *
+ * Side effects:
+ * The implementation supports cross-filesystem renames of files,
+ * but the caller should be prepared to emulate cross-filesystem
+ * renames of directories if errno is EXDEV.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+TclpRenameFile(
+ char *src, /* Pathname of file or dir to be renamed. */
+ char *dst) /* New pathname for file or directory. */
+{
+ DWORD srcAttr, dstAttr;
+
+ /*
+ * Would throw an exception under NT if one of the arguments is a
+ * char block device.
+ */
+
+ try {
+ if (MoveFile(src, dst) != FALSE) {
+ return TCL_OK;
+ }
+ } except (-1) {}
+
+ TclWinConvertError(GetLastError());
+
+ srcAttr = GetFileAttributes(src);
+ dstAttr = GetFileAttributes(dst);
+ if (srcAttr == (DWORD) -1) {
+ srcAttr = 0;
+ }
+ if (dstAttr == (DWORD) -1) {
+ dstAttr = 0;
+ }
+
+ if (errno == EBADF) {
+ errno = EACCES;
+ return TCL_ERROR;
+ }
+ if ((errno == EACCES) && (TclWinGetPlatformId() == VER_PLATFORM_WIN32s)) {
+ if ((srcAttr != 0) && (dstAttr != 0)) {
+ /*
+ * Win32s reports trying to overwrite an existing file or directory
+ * as EACCES.
+ */
+
+ errno = EEXIST;
+ }
+ }
+ if (errno == EACCES) {
+ decode:
+ if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) {
+ char srcPath[MAX_PATH], dstPath[MAX_PATH];
+ int srcArgc, dstArgc;
+ char **srcArgv, **dstArgv;
+ char *srcRest, *dstRest;
+ int size;
+
+ size = GetFullPathName(src, sizeof(srcPath), srcPath, &srcRest);
+ if ((size == 0) || (size > sizeof(srcPath))) {
+ return TCL_ERROR;
+ }
+ size = GetFullPathName(dst, sizeof(dstPath), dstPath, &dstRest);
+ if ((size == 0) || (size > sizeof(dstPath))) {
+ return TCL_ERROR;
+ }
+ if (srcRest == NULL) {
+ srcRest = srcPath + strlen(srcPath);
+ }
+ if (strnicmp(srcPath, dstPath, srcRest - srcPath) == 0) {
+ /*
+ * Trying to move a directory into itself.
+ */
+
+ errno = EINVAL;
+ return TCL_ERROR;
+ }
+ Tcl_SplitPath(srcPath, &srcArgc, &srcArgv);
+ Tcl_SplitPath(dstPath, &dstArgc, &dstArgv);
+ if (srcArgc == 1) {
+ /*
+ * They are trying to move a root directory. Whether
+ * or not it is across filesystems, this cannot be
+ * done.
+ */
+
+ errno = EINVAL;
+ } else if ((srcArgc > 0) && (dstArgc > 0) &&
+ (stricmp(srcArgv[0], dstArgv[0]) != 0)) {
+ /*
+ * If src is a directory and dst filesystem != src
+ * filesystem, errno should be EXDEV. It is very
+ * important to get this behavior, so that the caller
+ * can respond to a cross filesystem rename by
+ * simulating it with copy and delete. The MoveFile
+ * system call already handles the case of moving a
+ * file between filesystems.
+ */
+
+ errno = EXDEV;
+ }
+
+ ckfree((char *) srcArgv);
+ ckfree((char *) dstArgv);
+ }
+
+ /*
+ * Other types of access failure is that dst is a read-only
+ * filesystem, that an open file referred to src or dest, or that
+ * src or dest specified the current working directory on the
+ * current filesystem. EACCES is returned for those cases.
+ */
+
+ } else if (errno == EEXIST) {
+ /*
+ * Reports EEXIST any time the target already exists. If it makes
+ * sense, remove the old file and try renaming again.
+ */
+
+ if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) {
+ if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) {
+ /*
+ * Overwrite empty dst directory with src directory. The
+ * following call will remove an empty directory. If it
+ * fails, it's because it wasn't empty.
+ */
+
+ if (TclpRemoveDirectory(dst, 0, NULL) == TCL_OK) {
+ /*
+ * Now that that empty directory is gone, we can try
+ * renaming again. If that fails, we'll put this empty
+ * directory back, for completeness.
+ */
+
+ if (MoveFile(src, dst) != FALSE) {
+ return TCL_OK;
+ }
+
+ /*
+ * Some new error has occurred. Don't know what it
+ * could be, but report this one.
+ */
+
+ TclWinConvertError(GetLastError());
+ CreateDirectory(dst, NULL);
+ SetFileAttributes(dst, dstAttr);
+ if (errno == EACCES) {
+ /*
+ * Decode the EACCES to a more meaningful error.
+ */
+
+ goto decode;
+ }
+ }
+ } else { /* (dstAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */
+ errno = ENOTDIR;
+ }
+ } else { /* (srcAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */
+ if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) {
+ errno = EISDIR;
+ } else {
+ /*
+ * Overwrite existing file by:
+ *
+ * 1. Rename existing file to temp name.
+ * 2. Rename old file to new name.
+ * 3. If success, delete temp file. If failure,
+ * put temp file back to old name.
+ */
+
+ char tempName[MAX_PATH];
+ int result, size;
+ char *rest;
+
+ size = GetFullPathName(dst, sizeof(tempName), tempName, &rest);
+ if ((size == 0) || (size > sizeof(tempName)) || (rest == NULL)) {
+ return TCL_ERROR;
+ }
+ *rest = '\0';
+ result = TCL_ERROR;
+ if (GetTempFileName(tempName, "tclr", 0, tempName) != 0) {
+ /*
+ * Strictly speaking, need the following DeleteFile and
+ * MoveFile to be joined as an atomic operation so no
+ * other app comes along in the meantime and creates the
+ * same temp file.
+ */
+
+ DeleteFile(tempName);
+ if (MoveFile(dst, tempName) != FALSE) {
+ if (MoveFile(src, dst) != FALSE) {
+ SetFileAttributes(tempName, FILE_ATTRIBUTE_NORMAL);
+ DeleteFile(tempName);
+ return TCL_OK;
+ } else {
+ DeleteFile(dst);
+ MoveFile(tempName, dst);
+ }
+ }
+
+ /*
+ * Can't backup dst file or move src file. Return that
+ * error. Could happen if an open file refers to dst.
+ */
+
+ TclWinConvertError(GetLastError());
+ if (errno == EACCES) {
+ /*
+ * Decode the EACCES to a more meaningful error.
+ */
+
+ goto decode;
+ }
+ }
+ return result;
+ }
+ }
+ }
+ return TCL_ERROR;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclpCopyFile --
+ *
+ * Copy a single file (not a directory). If dst already exists and
+ * is not a directory, it is removed.
+ *
+ * Results:
+ * If the file was successfully copied, returns TCL_OK. Otherwise
+ * the return value is TCL_ERROR and errno is set to indicate the
+ * error. Some possible values for errno are:
+ *
+ * EACCES: src or dst parent directory can't be read and/or written.
+ * EISDIR: src or dst is a directory.
+ * ENOENT: src doesn't exist. src or dst is "".
+ *
+ * EACCES: exists an open file already referring to dst (95).
+ * EACCES: src specifies a char device (nul:, com1:, etc.) (NT)
+ * ENOENT: src specifies a char device (nul:, com1:, etc.) (95)
+ *
+ * Side effects:
+ * It is not an error to copy to a char device.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+TclpCopyFile(
+ char *src, /* Pathname of file to be copied. */
+ char *dst) /* Pathname of file to copy to. */
+{
+ /*
+ * Would throw an exception under NT if one of the arguments is a char
+ * block device.
+ */
+
+ try {
+ if (CopyFile(src, dst, 0) != FALSE) {
+ return TCL_OK;
+ }
+ } except (-1) {}
+
+ TclWinConvertError(GetLastError());
+ if (errno == EBADF) {
+ errno = EACCES;
+ return TCL_ERROR;
+ }
+ if (errno == EACCES) {
+ DWORD srcAttr, dstAttr;
+
+ srcAttr = GetFileAttributes(src);
+ dstAttr = GetFileAttributes(dst);
+ if (srcAttr != (DWORD) -1) {
+ if (dstAttr == (DWORD) -1) {
+ dstAttr = 0;
+ }
+ if ((srcAttr & FILE_ATTRIBUTE_DIRECTORY) ||
+ (dstAttr & FILE_ATTRIBUTE_DIRECTORY)) {
+ errno = EISDIR;
+ }
+ if (dstAttr & FILE_ATTRIBUTE_READONLY) {
+ SetFileAttributes(dst, dstAttr & ~FILE_ATTRIBUTE_READONLY);
+ if (CopyFile(src, dst, 0) != FALSE) {
+ return TCL_OK;
+ }
+ /*
+ * Still can't copy onto dst. Return that error, and
+ * restore attributes of dst.
+ */
+
+ TclWinConvertError(GetLastError());
+ SetFileAttributes(dst, dstAttr);
+ }
+ }
+ }
+ return TCL_ERROR;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclpDeleteFile --
+ *
+ * Removes a single file (not a directory).
+ *
+ * Results:
+ * If the file was successfully deleted, returns TCL_OK. Otherwise
+ * the return value is TCL_ERROR and errno is set to indicate the
+ * error. Some possible values for errno are:
+ *
+ * EACCES: a parent directory can't be read and/or written.
+ * EISDIR: path is a directory.
+ * ENOENT: path doesn't exist or is "".
+ *
+ * EACCES: exists an open file already referring to path.
+ * EACCES: path is a char device (nul:, com1:, etc.)
+ *
+ * Side effects:
+ * The file is deleted, even if it is read-only.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+TclpDeleteFile(
+ char *path) /* Pathname of file to be removed. */
+{
+ DWORD attr;
+
+ if (DeleteFile(path) != FALSE) {
+ return TCL_OK;
+ }
+ TclWinConvertError(GetLastError());
+ if (path[0] == '\0') {
+ /*
+ * Win32s thinks that "" is the same as "." and then reports EISDIR
+ * instead of ENOENT.
+ */
+
+ errno = ENOENT;
+ } else if (errno == EACCES) {
+ attr = GetFileAttributes(path);
+ if (attr != (DWORD) -1) {
+ if (attr & FILE_ATTRIBUTE_DIRECTORY) {
+ /*
+ * Windows NT reports removing a directory as EACCES instead
+ * of EISDIR.
+ */
+
+ errno = EISDIR;
+ } else if (attr & FILE_ATTRIBUTE_READONLY) {
+ SetFileAttributes(path, attr & ~FILE_ATTRIBUTE_READONLY);
+ if (DeleteFile(path) != FALSE) {
+ return TCL_OK;
+ }
+ TclWinConvertError(GetLastError());
+ SetFileAttributes(path, attr);
+ }
+ }
+ } else if (errno == ENOENT) {
+ attr = GetFileAttributes(path);
+ if (attr != (DWORD) -1) {
+ if (attr & FILE_ATTRIBUTE_DIRECTORY) {
+ /*
+ * Windows 95 reports removing a directory as ENOENT instead
+ * of EISDIR.
+ */
+
+ errno = EISDIR;
+ }
+ }
+ } else if (errno == EINVAL) {
+ /*
+ * Windows NT reports removing a char device as EINVAL instead of
+ * EACCES.
+ */
+
+ errno = EACCES;
+ }
+
+ return TCL_ERROR;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclpCreateDirectory --
+ *
+ * Creates the specified directory. All parent directories of the
+ * specified directory must already exist. The directory is
+ * automatically created with permissions so that user can access
+ * the new directory and create new files or subdirectories in it.
+ *
+ * Results:
+ * If the directory was successfully created, returns TCL_OK.
+ * Otherwise the return value is TCL_ERROR and errno is set to
+ * indicate the error. Some possible values for errno are:
+ *
+ * EACCES: a parent directory can't be read and/or written.
+ * EEXIST: path already exists.
+ * ENOENT: a parent directory doesn't exist.
+ *
+ * Side effects:
+ * A directory is created.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+TclpCreateDirectory(
+ char *path) /* Pathname of directory to create */
+{
+ int error;
+
+ if (CreateDirectory(path, NULL) == 0) {
+ error = GetLastError();
+ if (TclWinGetPlatformId() == VER_PLATFORM_WIN32s) {
+ if ((error == ERROR_ACCESS_DENIED)
+ && (GetFileAttributes(path) != (DWORD) -1)) {
+ error = ERROR_FILE_EXISTS;
+ }
+ }
+ TclWinConvertError(error);
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclpCopyDirectory --
+ *
+ * Recursively copies a directory. The target directory dst must
+ * not already exist. Note that this function does not merge two
+ * directory hierarchies, even if the target directory is an an
+ * empty directory.
+ *
+ * Results:
+ * If the directory was successfully copied, returns TCL_OK.
+ * Otherwise the return value is TCL_ERROR, errno is set to indicate
+ * the error, and the pathname of the file that caused the error
+ * is stored in errorPtr. See TclpCreateDirectory and TclpCopyFile
+ * for a description of possible values for errno.
+ *
+ * Side effects:
+ * An exact copy of the directory hierarchy src will be created
+ * with the name dst. If an error occurs, the error will
+ * be returned immediately, and remaining files will not be
+ * processed.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+TclpCopyDirectory(
+ char *src, /* Pathname of directory to be copied. */
+ char *dst, /* Pathname of target directory. */
+ Tcl_DString *errorPtr) /* If non-NULL, initialized DString for
+ * error reporting. */
+{
+ int result;
+ Tcl_DString srcBuffer;
+ Tcl_DString dstBuffer;
+
+ Tcl_DStringInit(&srcBuffer);
+ Tcl_DStringInit(&dstBuffer);
+ Tcl_DStringAppend(&srcBuffer, src, -1);
+ Tcl_DStringAppend(&dstBuffer, dst, -1);
+ result = TraverseWinTree(TraversalCopy, &srcBuffer, &dstBuffer,
+ errorPtr);
+ Tcl_DStringFree(&srcBuffer);
+ Tcl_DStringFree(&dstBuffer);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpRemoveDirectory --
+ *
+ * Removes directory (and its contents, if the recursive flag is set).
+ *
+ * Results:
+ * If the directory was successfully removed, returns TCL_OK.
+ * Otherwise the return value is TCL_ERROR, errno is set to indicate
+ * the error, and the pathname of the file that caused the error
+ * is stored in errorPtr. Some possible values for errno are:
+ *
+ * EACCES: path directory can't be read and/or written.
+ * EEXIST: path is a non-empty directory.
+ * EINVAL: path is root directory or current directory.
+ * ENOENT: path doesn't exist or is "".
+ * ENOTDIR: path is not a directory.
+ *
+ * EACCES: path is a char device (nul:, com1:, etc.) (95)
+ * EINVAL: path is a char device (nul:, com1:, etc.) (NT)
+ *
+ * Side effects:
+ * Directory removed. If an error occurs, the error will be returned
+ * immediately, and remaining files will not be deleted.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclpRemoveDirectory(
+ char *path, /* Pathname of directory to be removed. */
+ int recursive, /* If non-zero, removes directories that
+ * are nonempty. Otherwise, will only remove
+ * empty directories. */
+ Tcl_DString *errorPtr) /* If non-NULL, initialized DString for
+ * error reporting. */
+{
+ int result;
+ Tcl_DString buffer;
+ DWORD attr;
+
+ if (RemoveDirectory(path) != FALSE) {
+ return TCL_OK;
+ }
+ TclWinConvertError(GetLastError());
+ if (path[0] == '\0') {
+ /*
+ * Win32s thinks that "" is the same as "." and then reports EACCES
+ * instead of ENOENT.
+ */
+
+ errno = ENOENT;
+ }
+ if (errno == EACCES) {
+ attr = GetFileAttributes(path);
+ if (attr != (DWORD) -1) {
+ if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
+ /*
+ * Windows 95 reports calling RemoveDirectory on a file as an
+ * EACCES, not an ENOTDIR.
+ */
+
+ errno = ENOTDIR;
+ goto end;
+ }
+
+ if (attr & FILE_ATTRIBUTE_READONLY) {
+ attr &= ~FILE_ATTRIBUTE_READONLY;
+ if (SetFileAttributes(path, attr) == FALSE) {
+ goto end;
+ }
+ if (RemoveDirectory(path) != FALSE) {
+ return TCL_OK;
+ }
+ TclWinConvertError(GetLastError());
+ SetFileAttributes(path, attr | FILE_ATTRIBUTE_READONLY);
+ }
+
+ /*
+ * Windows 95 and Win32s report removing a non-empty directory
+ * as EACCES, not EEXIST. If the directory is not empty,
+ * change errno so caller knows what's going on.
+ */
+
+ if (TclWinGetPlatformId() != VER_PLATFORM_WIN32_NT) {
+ HANDLE handle;
+ WIN32_FIND_DATA data;
+ Tcl_DString buffer;
+ char *find;
+ int len;
+
+ Tcl_DStringInit(&buffer);
+ find = Tcl_DStringAppend(&buffer, path, -1);
+ len = Tcl_DStringLength(&buffer);
+ if ((len > 0) && (find[len - 1] != '\\')) {
+ Tcl_DStringAppend(&buffer, "\\", 1);
+ }
+ find = Tcl_DStringAppend(&buffer, "*.*", 3);
+ handle = FindFirstFile(find, &data);
+ if (handle != INVALID_HANDLE_VALUE) {
+ while (1) {
+ if ((strcmp(data.cFileName, ".") != 0)
+ && (strcmp(data.cFileName, "..") != 0)) {
+ /*
+ * Found something in this directory.
+ */
+
+ errno = EEXIST;
+ break;
+ }
+ if (FindNextFile(handle, &data) == FALSE) {
+ break;
+ }
+ }
+ FindClose(handle);
+ }
+ Tcl_DStringFree(&buffer);
+ }
+ }
+ }
+ if (errno == ENOTEMPTY) {
+ /*
+ * The caller depends on EEXIST to signify that the directory is
+ * not empty, not ENOTEMPTY.
+ */
+
+ errno = EEXIST;
+ }
+ if ((recursive != 0) && (errno == EEXIST)) {
+ /*
+ * The directory is nonempty, but the recursive flag has been
+ * specified, so we recursively remove all the files in the directory.
+ */
+
+ Tcl_DStringInit(&buffer);
+ Tcl_DStringAppend(&buffer, path, -1);
+ result = TraverseWinTree(TraversalDelete, &buffer, NULL, errorPtr);
+ Tcl_DStringFree(&buffer);
+ return result;
+ }
+
+ end:
+ if (errorPtr != NULL) {
+ Tcl_DStringAppend(errorPtr, path, -1);
+ }
+ return TCL_ERROR;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TraverseWinTree --
+ *
+ * Traverse directory tree specified by sourcePtr, calling the function
+ * traverseProc for each file and directory encountered. If destPtr
+ * is non-null, each of name in the sourcePtr directory is appended to
+ * the directory specified by destPtr and passed as the second argument
+ * to traverseProc() .
+ *
+ * Results:
+ * Standard Tcl result.
+ *
+ * Side effects:
+ * None caused by TraverseWinTree, however the user specified
+ * traverseProc() may change state. If an error occurs, the error will
+ * be returned immediately, and remaining files will not be processed.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static int
+TraverseWinTree(
+ TraversalProc *traverseProc,/* Function to call for every file and
+ * directory in source hierarchy. */
+ Tcl_DString *sourcePtr, /* Pathname of source directory to be
+ * traversed. */
+ Tcl_DString *targetPtr, /* Pathname of directory to traverse in
+ * parallel with source directory. */
+ Tcl_DString *errorPtr) /* If non-NULL, an initialized DString for
+ * error reporting. */
+{
+ DWORD sourceAttr;
+ char *source, *target, *errfile;
+ int result, sourceLen, targetLen, sourceLenOriginal, targetLenOriginal;
+ HANDLE handle;
+ WIN32_FIND_DATA data;
+
+ result = TCL_OK;
+ source = Tcl_DStringValue(sourcePtr);
+ sourceLenOriginal = Tcl_DStringLength(sourcePtr);
+ if (targetPtr != NULL) {
+ target = Tcl_DStringValue(targetPtr);
+ targetLenOriginal = Tcl_DStringLength(targetPtr);
+ } else {
+ target = NULL;
+ targetLenOriginal = 0;
+ }
+
+ errfile = NULL;
+
+ sourceAttr = GetFileAttributes(source);
+ if (sourceAttr == (DWORD) -1) {
+ errfile = source;
+ goto end;
+ }
+ if ((sourceAttr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
+ /*
+ * Process the regular file
+ */
+
+ return (*traverseProc)(source, target, sourceAttr, DOTREE_F, errorPtr);
+ }
+
+ /*
+ * When given the pathname of the form "c:\" (one that already ends
+ * with a backslash), must make sure not to add another "\" to the end
+ * otherwise it will try to access a network drive.
+ */
+
+ sourceLen = sourceLenOriginal;
+ if ((sourceLen > 0) && (source[sourceLen - 1] != '\\')) {
+ Tcl_DStringAppend(sourcePtr, "\\", 1);
+ sourceLen++;
+ }
+ source = Tcl_DStringAppend(sourcePtr, "*.*", 3);
+ handle = FindFirstFile(source, &data);
+ Tcl_DStringSetLength(sourcePtr, sourceLen);
+ if (handle == INVALID_HANDLE_VALUE) {
+ /*
+ * Can't read directory
+ */
+
+ TclWinConvertError(GetLastError());
+ errfile = source;
+ goto end;
+ }
+
+ result = (*traverseProc)(source, target, sourceAttr, DOTREE_PRED, errorPtr);
+ if (result != TCL_OK) {
+ FindClose(handle);
+ return result;
+ }
+
+ if (targetPtr != NULL) {
+ targetLen = targetLenOriginal;
+ if ((targetLen > 0) && (target[targetLen - 1] != '\\')) {
+ target = Tcl_DStringAppend(targetPtr, "\\", 1);
+ targetLen++;
+ }
+ }
+
+ while (1) {
+ if ((strcmp(data.cFileName, ".") != 0)
+ && (strcmp(data.cFileName, "..") != 0)) {
+ /*
+ * Append name after slash, and recurse on the file.
+ */
+
+ Tcl_DStringAppend(sourcePtr, data.cFileName, -1);
+ if (targetPtr != NULL) {
+ Tcl_DStringAppend(targetPtr, data.cFileName, -1);
+ }
+ result = TraverseWinTree(traverseProc, sourcePtr, targetPtr,
+ errorPtr);
+ if (result != TCL_OK) {
+ break;
+ }
+
+ /*
+ * Remove name after slash.
+ */
+
+ Tcl_DStringSetLength(sourcePtr, sourceLen);
+ if (targetPtr != NULL) {
+ Tcl_DStringSetLength(targetPtr, targetLen);
+ }
+ }
+ if (FindNextFile(handle, &data) == FALSE) {
+ break;
+ }
+ }
+ FindClose(handle);
+
+ /*
+ * Strip off the trailing slash we added
+ */
+
+ Tcl_DStringSetLength(sourcePtr, sourceLenOriginal);
+ source = Tcl_DStringValue(sourcePtr);
+ if (targetPtr != NULL) {
+ Tcl_DStringSetLength(targetPtr, targetLenOriginal);
+ target = Tcl_DStringValue(targetPtr);
+ }
+
+ if (result == TCL_OK) {
+ /*
+ * Call traverseProc() on a directory after visiting all the
+ * files in that directory.
+ */
+
+ result = (*traverseProc)(source, target, sourceAttr,
+ DOTREE_POSTD, errorPtr);
+ }
+ end:
+ if (errfile != NULL) {
+ TclWinConvertError(GetLastError());
+ if (errorPtr != NULL) {
+ Tcl_DStringAppend(errorPtr, errfile, -1);
+ }
+ result = TCL_ERROR;
+ }
+
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TraversalCopy
+ *
+ * Called from TraverseUnixTree in order to execute a recursive
+ * copy of a directory.
+ *
+ * Results:
+ * Standard Tcl result.
+ *
+ * Side effects:
+ * Depending on the value of type, src may be copied to dst.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TraversalCopy(
+ char *src, /* Source pathname to copy. */
+ char *dst, /* Destination pathname of copy. */
+ DWORD srcAttr, /* File attributes for src. */
+ int type, /* Reason for call - see TraverseWinTree() */
+ Tcl_DString *errorPtr) /* If non-NULL, initialized DString for
+ * error return. */
+{
+ switch (type) {
+ case DOTREE_F:
+ if (TclpCopyFile(src, dst) == TCL_OK) {
+ return TCL_OK;
+ }
+ break;
+
+ case DOTREE_PRED:
+ if (TclpCreateDirectory(dst) == TCL_OK) {
+ if (SetFileAttributes(dst, srcAttr) != FALSE) {
+ return TCL_OK;
+ }
+ TclWinConvertError(GetLastError());
+ }
+ break;
+
+ case DOTREE_POSTD:
+ return TCL_OK;
+
+ }
+
+ /*
+ * There shouldn't be a problem with src, because we already
+ * checked it to get here.
+ */
+
+ if (errorPtr != NULL) {
+ Tcl_DStringAppend(errorPtr, dst, -1);
+ }
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TraversalDelete --
+ *
+ * Called by procedure TraverseWinTree for every file and
+ * directory that it encounters in a directory hierarchy. This
+ * procedure unlinks files, and removes directories after all the
+ * containing files have been processed.
+ *
+ * Results:
+ * Standard Tcl result.
+ *
+ * Side effects:
+ * Files or directory specified by src will be deleted. If an
+ * error occurs, the windows error is converted to a Posix error
+ * and errno is set accordingly.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TraversalDelete(
+ char *src, /* Source pathname. */
+ char *ignore, /* Destination pathname (not used). */
+ DWORD srcAttr, /* File attributes for src (not used). */
+ int type, /* Reason for call - see TraverseWinTree(). */
+ Tcl_DString *errorPtr) /* If non-NULL, initialized DString for
+ * error return. */
+{
+ switch (type) {
+ case DOTREE_F:
+ if (TclpDeleteFile(src) == TCL_OK) {
+ return TCL_OK;
+ }
+ break;
+
+ case DOTREE_PRED:
+ return TCL_OK;
+
+ case DOTREE_POSTD:
+ if (TclpRemoveDirectory(src, 0, NULL) == TCL_OK) {
+ return TCL_OK;
+ }
+ break;
+
+ }
+
+ if (errorPtr != NULL) {
+ Tcl_DStringAppend(errorPtr, src, -1);
+ }
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * AttributesPosixError --
+ *
+ * Sets the object result with the appropriate error.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The interp's object result is set with an error message
+ * based on the objIndex, fileName and errno.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+AttributesPosixError(
+ Tcl_Interp *interp, /* The interp that has the error */
+ int objIndex, /* The attribute which caused the problem. */
+ char *fileName, /* The name of the file which caused the
+ * error. */
+ int getOrSet) /* 0 for get; 1 for set */
+{
+ TclWinConvertError(GetLastError());
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "cannot ", getOrSet ? "set" : "get", " attribute \"",
+ tclpFileAttrStrings[objIndex], "\" for file \"", fileName,
+ "\": ", Tcl_PosixError(interp), (char *) NULL);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * GetWinFileAttributes --
+ *
+ * Returns a Tcl_Obj containing the value of a file attribute.
+ * This routine gets the -hidden, -readonly or -system attribute.
+ *
+ * Results:
+ * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object
+ * will have ref count 0. If the return value is not TCL_OK,
+ * attributePtrPtr is not touched.
+ *
+ * Side effects:
+ * A new object is allocated if the file is valid.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+GetWinFileAttributes(
+ Tcl_Interp *interp, /* The interp we are using for errors. */
+ int objIndex, /* The index of the attribute. */
+ char *fileName, /* The name of the file. */
+ Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
+{
+ DWORD result = GetFileAttributes(fileName);
+
+ if (result == 0xFFFFFFFF) {
+ AttributesPosixError(interp, objIndex, fileName, 0);
+ return TCL_ERROR;
+ }
+
+ *attributePtrPtr = Tcl_NewBooleanObj(result & attributeArray[objIndex]);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ConvertFileNameFormat --
+ *
+ * Returns a Tcl_Obj containing either the long or short version of the
+ * file name.
+ *
+ * Results:
+ * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object
+ * will have ref count 0. If the return value is not TCL_OK,
+ * attributePtrPtr is not touched.
+ *
+ * Side effects:
+ * A new object is allocated if the file is valid.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ConvertFileNameFormat(
+ Tcl_Interp *interp, /* The interp we are using for errors. */
+ int objIndex, /* The index of the attribute. */
+ char *fileName, /* The name of the file. */
+ int longShort, /* 0 to short name, 1 to long name. */
+ Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
+{
+ HANDLE findHandle;
+ WIN32_FIND_DATA findData;
+ int pathArgc, i;
+ char **pathArgv, **newPathArgv;
+ char *currentElement, *resultStr;
+ Tcl_DString resultDString;
+ int result = TCL_OK;
+
+ Tcl_SplitPath(fileName, &pathArgc, &pathArgv);
+ newPathArgv = (char **) ckalloc(pathArgc * sizeof(char *));
+
+ i = 0;
+ if ((pathArgv[0][0] == '/')
+ || ((strlen(pathArgv[0]) == 3) && (pathArgv[0][1] == ':'))) {
+ newPathArgv[0] = (char *) ckalloc(strlen(pathArgv[0]) + 1);
+ strcpy(newPathArgv[0], pathArgv[0]);
+ i = 1;
+ }
+ for ( ; i < pathArgc; i++) {
+ if (strcmp(pathArgv[i], ".") == 0) {
+ currentElement = ckalloc(2);
+ strcpy(currentElement, ".");
+ } else if (strcmp(pathArgv[i], "..") == 0) {
+ currentElement = ckalloc(3);
+ strcpy(currentElement, "..");
+ } else {
+ int useLong;
+
+ Tcl_DStringInit(&resultDString);
+ resultStr = Tcl_JoinPath(i + 1, pathArgv, &resultDString);
+ findHandle = FindFirstFile(resultStr, &findData);
+ if (findHandle == INVALID_HANDLE_VALUE) {
+ pathArgc = i - 1;
+ AttributesPosixError(interp, objIndex, fileName, 0);
+ result = TCL_ERROR;
+ Tcl_DStringFree(&resultDString);
+ goto cleanup;
+ }
+ if (longShort) {
+ if (findData.cFileName[0] != '\0') {
+ useLong = 1;
+ } else {
+ useLong = 0;
+ }
+ } else {
+ if (findData.cAlternateFileName[0] == '\0') {
+ useLong = 1;
+ } else {
+ useLong = 0;
+ }
+ }
+ if (useLong) {
+ currentElement = ckalloc(strlen(findData.cFileName) + 1);
+ strcpy(currentElement, findData.cFileName);
+ } else {
+ currentElement = ckalloc(strlen(findData.cAlternateFileName)
+ + 1);
+ strcpy(currentElement, findData.cAlternateFileName);
+ }
+ Tcl_DStringFree(&resultDString);
+ FindClose(findHandle);
+ }
+ newPathArgv[i] = currentElement;
+ }
+
+ Tcl_DStringInit(&resultDString);
+ resultStr = Tcl_JoinPath(pathArgc, newPathArgv, &resultDString);
+ *attributePtrPtr = Tcl_NewStringObj(resultStr, Tcl_DStringLength(&resultDString));
+ Tcl_DStringFree(&resultDString);
+
+cleanup:
+ for (i = 0; i < pathArgc; i++) {
+ ckfree(newPathArgv[i]);
+ }
+ ckfree((char *) newPathArgv);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * GetWinFileLongName --
+ *
+ * Returns a Tcl_Obj containing the short version of the file
+ * name.
+ *
+ * Results:
+ * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object
+ * will have ref count 0. If the return value is not TCL_OK,
+ * attributePtrPtr is not touched.
+ *
+ * Side effects:
+ * A new object is allocated if the file is valid.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+GetWinFileLongName(
+ Tcl_Interp *interp, /* The interp we are using for errors. */
+ int objIndex, /* The index of the attribute. */
+ char *fileName, /* The name of the file. */
+ Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
+{
+ return ConvertFileNameFormat(interp, objIndex, fileName, 1, attributePtrPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * GetWinFileShortName --
+ *
+ * Returns a Tcl_Obj containing the short version of the file
+ * name.
+ *
+ * Results:
+ * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object
+ * will have ref count 0. If the return value is not TCL_OK,
+ * attributePtrPtr is not touched.
+ *
+ * Side effects:
+ * A new object is allocated if the file is valid.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+GetWinFileShortName(
+ Tcl_Interp *interp, /* The interp we are using for errors. */
+ int objIndex, /* The index of the attribute. */
+ char *fileName, /* The name of the file. */
+ Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
+{
+ return ConvertFileNameFormat(interp, objIndex, fileName, 0, attributePtrPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SetWinFileAttributes --
+ *
+ * Set the file attributes to the value given by attributePtr.
+ * This routine sets the -hidden, -readonly, or -system attributes.
+ *
+ * Results:
+ * Standard TCL error.
+ *
+ * Side effects:
+ * The file's attribute is set.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SetWinFileAttributes(
+ Tcl_Interp *interp, /* The interp we are using for errors. */
+ int objIndex, /* The index of the attribute. */
+ char *fileName, /* The name of the file. */
+ Tcl_Obj *attributePtr) /* The new value of the attribute. */
+{
+ DWORD fileAttributes = GetFileAttributes(fileName);
+ int yesNo;
+ int result;
+
+ if (fileAttributes == 0xFFFFFFFF) {
+ AttributesPosixError(interp, objIndex, fileName, 1);
+ return TCL_ERROR;
+ }
+
+ result = Tcl_GetBooleanFromObj(interp, attributePtr, &yesNo);
+ if (result != TCL_OK) {
+ return result;
+ }
+
+ if (yesNo) {
+ fileAttributes |= (attributeArray[objIndex]);
+ } else {
+ fileAttributes &= ~(attributeArray[objIndex]);
+ }
+
+ if (!SetFileAttributes(fileName, fileAttributes)) {
+ AttributesPosixError(interp, objIndex, fileName, 1);
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SetWinFileLongName --
+ *
+ * The attribute in question is a readonly attribute and cannot
+ * be set.
+ *
+ * Results:
+ * TCL_ERROR
+ *
+ * Side effects:
+ * The object result is set to a pertinant error message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CannotSetAttribute(
+ Tcl_Interp *interp, /* The interp we are using for errors. */
+ int objIndex, /* The index of the attribute. */
+ char *fileName, /* The name of the file. */
+ Tcl_Obj *attributePtr) /* The new value of the attribute. */
+{
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "cannot set attribute \"", tclpFileAttrStrings[objIndex],
+ "\" for file \"", fileName, "\" : attribute is readonly",
+ (char *) NULL);
+ return TCL_ERROR;
+}
+
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclpListVolumes --
+ *
+ * Lists the currently mounted volumes
+ *
+ * Results:
+ * A standard Tcl result. Will always be TCL_OK, since there is no way
+ * that this command can fail. Also, the interpreter's result is set to
+ * the list of volumes.
+ *
+ * Side effects:
+ * None
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+TclpListVolumes(
+ Tcl_Interp *interp) /* Interpreter to which to pass the volume list */
+{
+ Tcl_Obj *resultPtr, *elemPtr;
+ char buf[4];
+ int i;
+
+ resultPtr = Tcl_GetObjResult(interp);
+
+ buf[1] = ':';
+ buf[2] = '/';
+ buf[3] = '\0';
+
+ /*
+ * On Win32s:
+ * GetLogicalDriveStrings() isn't implemented.
+ * GetLogicalDrives() returns incorrect information.
+ */
+
+ for (i = 0; i < 26; i++) {
+ buf[0] = (char) ('a' + i);
+ if (GetVolumeInformation(buf, NULL, 0, NULL, NULL, NULL, NULL, 0)
+ || (GetLastError() == ERROR_NOT_READY)) {
+ elemPtr = Tcl_NewStringObj(buf, -1);
+ Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr);
+ }
+ }
+ return TCL_OK;
+}
diff --git a/win/tclWinFile.c b/win/tclWinFile.c
new file mode 100644
index 0000000..9d97b02
--- /dev/null
+++ b/win/tclWinFile.c
@@ -0,0 +1,647 @@
+/*
+ * tclWinFile.c --
+ *
+ * This file contains temporary wrappers around UNIX file handling
+ * functions. These wrappers map the UNIX functions to Win32 HANDLE-style
+ * files, which can be manipulated through the Win32 console redirection
+ * interfaces.
+ *
+ * Copyright (c) 1995-1996 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclWinFile.c 1.45 97/10/29 19:08:35
+ */
+
+#include "tclWinInt.h"
+#include <sys/stat.h>
+#include <shlobj.h>
+
+/*
+ * The variable below caches the name of the current working directory
+ * in order to avoid repeated calls to getcwd. The string is malloc-ed.
+ * NULL means the cache needs to be refreshed.
+ */
+
+static char *currentDir = NULL;
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FindExecutable --
+ *
+ * This procedure computes the absolute path name of the current
+ * application, given its argv[0] value.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The variable tclExecutableName gets filled in with the file
+ * name for the application, if we figured it out. If we couldn't
+ * figure it out, Tcl_FindExecutable is set to NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_FindExecutable(argv0)
+ char *argv0; /* The value of the application's argv[0]. */
+{
+ Tcl_DString buffer;
+ int length;
+
+ Tcl_DStringInit(&buffer);
+
+ if (tclExecutableName != NULL) {
+ ckfree(tclExecutableName);
+ tclExecutableName = NULL;
+ }
+
+ /*
+ * Under Windows we ignore argv0, and return the path for the file used to
+ * create this process.
+ */
+
+ Tcl_DStringSetLength(&buffer, MAX_PATH+1);
+ length = GetModuleFileName(NULL, Tcl_DStringValue(&buffer), MAX_PATH+1);
+ if (length > 0) {
+ tclExecutableName = (char *) ckalloc((unsigned) (length + 1));
+ strcpy(tclExecutableName, Tcl_DStringValue(&buffer));
+ }
+ Tcl_DStringFree(&buffer);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclMatchFiles --
+ *
+ * This routine is used by the globbing code to search a
+ * directory for all files which match a given pattern.
+ *
+ * Results:
+ * If the tail argument is NULL, then the matching files are
+ * added to the interp->result. Otherwise, TclDoGlob is called
+ * recursively for each matching subdirectory. The return value
+ * is a standard Tcl result indicating whether an error occurred
+ * in globbing.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------- */
+
+int
+TclMatchFiles(interp, separators, dirPtr, pattern, tail)
+ Tcl_Interp *interp; /* Interpreter to receive results. */
+ char *separators; /* Directory separators to pass to TclDoGlob. */
+ Tcl_DString *dirPtr; /* Contains path to directory to search. */
+ char *pattern; /* Pattern to match against. */
+ char *tail; /* Pointer to end of pattern. Tail must
+ * point to a location in pattern. */
+{
+ char drivePattern[4] = "?:\\";
+ char *newPattern, *p, *dir, *root, c;
+ char *src, *dest;
+ int length, matchDotFiles;
+ int result = TCL_OK;
+ int baseLength = Tcl_DStringLength(dirPtr);
+ Tcl_DString buffer;
+ DWORD atts, volFlags;
+ HANDLE handle;
+ WIN32_FIND_DATA data;
+ BOOL found;
+
+ /*
+ * Convert the path to normalized form since some interfaces only
+ * accept backslashes. Also, ensure that the directory ends with a
+ * separator character.
+ */
+
+ Tcl_DStringInit(&buffer);
+ if (baseLength == 0) {
+ Tcl_DStringAppend(&buffer, ".", 1);
+ } else {
+ Tcl_DStringAppend(&buffer, Tcl_DStringValue(dirPtr),
+ Tcl_DStringLength(dirPtr));
+ }
+ for (p = Tcl_DStringValue(&buffer); *p != '\0'; p++) {
+ if (*p == '/') {
+ *p = '\\';
+ }
+ }
+ p--;
+ if (*p != '\\' && *p != ':') {
+ Tcl_DStringAppend(&buffer, "\\", 1);
+ }
+ dir = Tcl_DStringValue(&buffer);
+
+ /*
+ * First verify that the specified path is actually a directory.
+ */
+
+ atts = GetFileAttributes(dir);
+ if ((atts == 0xFFFFFFFF) || ((atts & FILE_ATTRIBUTE_DIRECTORY) == 0)) {
+ Tcl_DStringFree(&buffer);
+ return TCL_OK;
+ }
+
+ /*
+ * Next check the volume information for the directory to see whether
+ * comparisons should be case sensitive or not. If the root is null, then
+ * we use the root of the current directory. If the root is just a drive
+ * specifier, we use the root directory of the given drive.
+ */
+
+ switch (Tcl_GetPathType(dir)) {
+ case TCL_PATH_RELATIVE:
+ found = GetVolumeInformation(NULL, NULL, 0, NULL,
+ NULL, &volFlags, NULL, 0);
+ break;
+ case TCL_PATH_VOLUME_RELATIVE:
+ if (*dir == '\\') {
+ root = NULL;
+ } else {
+ root = drivePattern;
+ *root = *dir;
+ }
+ found = GetVolumeInformation(root, NULL, 0, NULL,
+ NULL, &volFlags, NULL, 0);
+ break;
+ case TCL_PATH_ABSOLUTE:
+ if (dir[1] == ':') {
+ root = drivePattern;
+ *root = *dir;
+ found = GetVolumeInformation(root, NULL, 0, NULL,
+ NULL, &volFlags, NULL, 0);
+ } else if (dir[1] == '\\') {
+ p = strchr(dir+2, '\\');
+ p = strchr(p+1, '\\');
+ p++;
+ c = *p;
+ *p = 0;
+ found = GetVolumeInformation(dir, NULL, 0, NULL,
+ NULL, &volFlags, NULL, 0);
+ *p = c;
+ }
+ break;
+ }
+
+ if (!found) {
+ Tcl_DStringFree(&buffer);
+ TclWinConvertError(GetLastError());
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "couldn't read volume information for \"",
+ dirPtr->string, "\": ", Tcl_PosixError(interp), (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * In Windows, although some volumes may support case sensitivity, Windows
+ * doesn't honor case. So in globbing we need to ignore the case
+ * of file names.
+ */
+
+ length = tail - pattern;
+ newPattern = ckalloc(length+1);
+ for (src = pattern, dest = newPattern; src < tail; src++, dest++) {
+ *dest = (char) tolower(*src);
+ }
+ *dest = '\0';
+
+ /*
+ * We need to check all files in the directory, so append a *.*
+ * to the path.
+ */
+
+
+ dir = Tcl_DStringAppend(&buffer, "*.*", 3);
+
+ /*
+ * Now open the directory for reading and iterate over the contents.
+ */
+
+ handle = FindFirstFile(dir, &data);
+ Tcl_DStringFree(&buffer);
+
+ if (handle == INVALID_HANDLE_VALUE) {
+ TclWinConvertError(GetLastError());
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "couldn't read directory \"",
+ dirPtr->string, "\": ", Tcl_PosixError(interp), (char *) NULL);
+ ckfree(newPattern);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Clean up the tail pointer. Leave the tail pointing to the
+ * first character after the path separator or NULL.
+ */
+
+ if (*tail == '\\') {
+ tail++;
+ }
+ if (*tail == '\0') {
+ tail = NULL;
+ } else {
+ tail++;
+ }
+
+ /*
+ * Check to see if the pattern needs to compare with dot files.
+ */
+
+ if ((newPattern[0] == '.')
+ || ((pattern[0] == '\\') && (pattern[1] == '.'))) {
+ matchDotFiles = 1;
+ } else {
+ matchDotFiles = 0;
+ }
+
+ /*
+ * Now iterate over all of the files in the directory.
+ */
+
+ Tcl_DStringInit(&buffer);
+ for (found = 1; found; found = FindNextFile(handle, &data)) {
+ char *matchResult;
+
+ /*
+ * Ignore hidden files.
+ */
+
+ if (!matchDotFiles && (data.cFileName[0] == '.')) {
+ continue;
+ }
+
+ /*
+ * Check to see if the file matches the pattern. We need to convert
+ * the file name to lower case for comparison purposes. Note that we
+ * are ignoring the case sensitivity flag because Windows doesn't honor
+ * case even if the volume is case sensitive. If the volume also
+ * doesn't preserve case, then we return the lower case form of the
+ * name, otherwise we return the system form.
+ */
+
+ matchResult = NULL;
+ Tcl_DStringSetLength(&buffer, 0);
+ Tcl_DStringAppend(&buffer, data.cFileName, -1);
+ for (p = buffer.string; *p != '\0'; p++) {
+ *p = (char) tolower(*p);
+ }
+ if (Tcl_StringMatch(buffer.string, newPattern)) {
+ if (volFlags & FS_CASE_IS_PRESERVED) {
+ matchResult = data.cFileName;
+ } else {
+ matchResult = buffer.string;
+ }
+ }
+
+ if (matchResult == NULL) {
+ continue;
+ }
+
+ /*
+ * If the file matches, then we need to process the remainder of the
+ * path. If there are more characters to process, then ensure matching
+ * files are directories and call TclDoGlob. Otherwise, just add the
+ * file to the result.
+ */
+
+ Tcl_DStringSetLength(dirPtr, baseLength);
+ Tcl_DStringAppend(dirPtr, matchResult, -1);
+ if (tail == NULL) {
+ Tcl_AppendElement(interp, dirPtr->string);
+ } else {
+ atts = GetFileAttributes(dirPtr->string);
+ if (atts & FILE_ATTRIBUTE_DIRECTORY) {
+ Tcl_DStringAppend(dirPtr, "/", 1);
+ result = TclDoGlob(interp, separators, dirPtr, tail);
+ if (result != TCL_OK) {
+ break;
+ }
+ }
+ }
+ }
+
+ Tcl_DStringFree(&buffer);
+ FindClose(handle);
+ ckfree(newPattern);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclChdir --
+ *
+ * Change the current working directory.
+ *
+ * Results:
+ * The result is a standard Tcl result. If an error occurs and
+ * interp isn't NULL, an error message is left in interp->result.
+ *
+ * Side effects:
+ * The working directory for this application is changed. Also
+ * the cache maintained used by TclGetCwd is deallocated and
+ * set to NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclChdir(interp, dirName)
+ Tcl_Interp *interp; /* If non NULL, used for error reporting. */
+ char *dirName; /* Path to new working directory. */
+{
+ if (currentDir != NULL) {
+ ckfree(currentDir);
+ currentDir = NULL;
+ }
+ if (!SetCurrentDirectory(dirName)) {
+ TclWinConvertError(GetLastError());
+ if (interp != NULL) {
+ Tcl_AppendResult(interp, "couldn't change working directory to \"",
+ dirName, "\": ", Tcl_PosixError(interp), (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclGetCwd --
+ *
+ * Return the path name of the current working directory.
+ *
+ * Results:
+ * The result is the full path name of the current working
+ * directory, or NULL if an error occurred while figuring it
+ * out. If an error occurs and interp isn't NULL, an error
+ * message is left in interp->result.
+ *
+ * Side effects:
+ * The path name is cached to avoid having to recompute it
+ * on future calls; if it is already cached, the cached
+ * value is returned.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+TclGetCwd(interp)
+ Tcl_Interp *interp; /* If non NULL, used for error reporting. */
+{
+ static char buffer[MAXPATHLEN+1];
+ char *bufPtr, *p;
+
+ if (currentDir == NULL) {
+ if (GetCurrentDirectory(MAXPATHLEN+1, buffer) == 0) {
+ TclWinConvertError(GetLastError());
+ if (interp != NULL) {
+ if (errno == ERANGE) {
+ Tcl_SetResult(interp,
+ "working directory name is too long",
+ TCL_STATIC);
+ } else {
+ Tcl_AppendResult(interp,
+ "error getting working directory name: ",
+ Tcl_PosixError(interp), (char *) NULL);
+ }
+ }
+ return NULL;
+ }
+ /*
+ * Watch for the wierd Windows '95 c:\\UNC syntax.
+ */
+
+ if (buffer[0] != '\0' && buffer[1] == ':' && buffer[2] == '\\'
+ && buffer[3] == '\\') {
+ bufPtr = &buffer[2];
+ } else {
+ bufPtr = buffer;
+ }
+
+ /*
+ * Convert to forward slashes for easier use in scripts.
+ */
+
+ for (p = bufPtr; *p != '\0'; p++) {
+ if (*p == '\\') {
+ *p = '/';
+ }
+ }
+ }
+ return bufPtr;
+}
+
+#if 0
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclWinResolveShortcut --
+ *
+ * Resolve a potential Windows shortcut to get the actual file or
+ * directory in question.
+ *
+ * Results:
+ * Returns 1 if the shortcut could be resolved, or 0 if there was
+ * an error or if the filename was not a shortcut.
+ * If bufferPtr did hold the name of a shortcut, it is modified to
+ * hold the resolved target of the shortcut instead.
+ *
+ * Side effects:
+ * Loads and unloads OLE package to determine if filename refers to
+ * a shortcut.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+int
+TclWinResolveShortcut(bufferPtr)
+ Tcl_DString *bufferPtr; /* Holds name of file to resolve. On
+ * return, holds resolved file name. */
+{
+ HRESULT hres;
+ IShellLink *psl;
+ IPersistFile *ppf;
+ WIN32_FIND_DATA wfd;
+ WCHAR wpath[MAX_PATH];
+ char *path, *ext;
+ char realFileName[MAX_PATH];
+
+ /*
+ * Windows system calls do not automatically resolve
+ * shortcuts like UNIX automatically will with symbolic links.
+ */
+
+ path = Tcl_DStringValue(bufferPtr);
+ ext = strrchr(path, '.');
+ if ((ext == NULL) || (stricmp(ext, ".lnk") != 0)) {
+ return 0;
+ }
+
+ CoInitialize(NULL);
+ path = Tcl_DStringValue(bufferPtr);
+ realFileName[0] = '\0';
+ hres = CoCreateInstance(&CLSID_ShellLink, NULL, CLSCTX_INPROC_SERVER,
+ &IID_IShellLink, &psl);
+ if (SUCCEEDED(hres)) {
+ hres = psl->lpVtbl->QueryInterface(psl, &IID_IPersistFile, &ppf);
+ if (SUCCEEDED(hres)) {
+ MultiByteToWideChar(CP_ACP, 0, path, -1, wpath, sizeof(wpath));
+ hres = ppf->lpVtbl->Load(ppf, wpath, STGM_READ);
+ if (SUCCEEDED(hres)) {
+ hres = psl->lpVtbl->Resolve(psl, NULL,
+ SLR_ANY_MATCH | SLR_NO_UI);
+ if (SUCCEEDED(hres)) {
+ hres = psl->lpVtbl->GetPath(psl, realFileName, MAX_PATH,
+ &wfd, 0);
+ }
+ }
+ ppf->lpVtbl->Release(ppf);
+ }
+ psl->lpVtbl->Release(psl);
+ }
+ CoUninitialize();
+
+ if (realFileName[0] != '\0') {
+ Tcl_DStringSetLength(bufferPtr, 0);
+ Tcl_DStringAppend(bufferPtr, realFileName, -1);
+ return 1;
+ }
+ return 0;
+}
+#endif
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclWinStat, TclWinLstat --
+ *
+ * These functions replace the library versions of stat and lstat.
+ *
+ * The stat and lstat functions provided by some Windows compilers
+ * are incomplete. Ideally, a complete rewrite of stat would go
+ * here; now, the only fix is that stat("c:") used to return an
+ * error instead infor for current dir on specified drive.
+ *
+ * Results:
+ * See stat documentation.
+ *
+ * Side effects:
+ * See stat documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclWinStat(path, buf)
+ CONST char *path; /* Path of file to stat (in current CP). */
+ struct stat *buf; /* Filled with results of stat call. */
+{
+ char name[4];
+ int result;
+
+ if ((strlen(path) == 2) && (path[1] == ':')) {
+ strcpy(name, path);
+ name[2] = '.';
+ name[3] = '\0';
+ path = name;
+ }
+
+#undef stat
+
+ result = stat(path, buf);
+
+#ifndef _MSC_VER
+
+ /*
+ * Borland's stat doesn't take into account localtime.
+ */
+
+ if ((result == 0) && (buf->st_mtime != 0)) {
+ TIME_ZONE_INFORMATION tz;
+ int time, bias;
+
+ time = GetTimeZoneInformation(&tz);
+ bias = tz.Bias;
+ if (time == TIME_ZONE_ID_DAYLIGHT) {
+ bias += tz.DaylightBias;
+ }
+ bias *= 60;
+ buf->st_atime -= bias;
+ buf->st_ctime -= bias;
+ buf->st_mtime -= bias;
+ }
+
+#endif
+
+ return result;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclWinAccess --
+ *
+ * This function replaces the library version of access.
+ *
+ * The library version of access returns that all files have execute
+ * permission.
+ *
+ * Results:
+ * See access documentation.
+ *
+ * Side effects:
+ * See access documentation.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+TclWinAccess(
+ CONST char *path, /* Path of file to access (in current CP). */
+ int mode) /* Permission setting. */
+{
+ int result;
+ CONST char *p;
+
+#undef access
+
+ result = access(path, mode);
+
+ if (result == 0) {
+ if (mode & 1) {
+ if (GetFileAttributes(path) & FILE_ATTRIBUTE_DIRECTORY) {
+ /*
+ * Directories are always executable.
+ */
+
+ return 0;
+ }
+ p = strrchr(path, '.');
+ if (p != NULL) {
+ p++;
+ if ((stricmp(p, "exe") == 0)
+ || (stricmp(p, "com") == 0)
+ || (stricmp(p, "bat") == 0)) {
+ /*
+ * File that ends with .exe, .com, or .bat is executable.
+ */
+
+ return 0;
+ }
+ }
+ errno = EACCES;
+ return -1;
+ }
+ }
+ return result;
+}
+
diff --git a/win/tclWinInit.c b/win/tclWinInit.c
new file mode 100644
index 0000000..be8dbbd
--- /dev/null
+++ b/win/tclWinInit.c
@@ -0,0 +1,394 @@
+/*
+ * tclWinInit.c --
+ *
+ * Contains the Windows-specific interpreter initialization functions.
+ *
+ * Copyright (c) 1994-1996 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclWinInit.c 1.32 97/06/24 17:28:26
+ */
+
+#include "tclInt.h"
+#include "tclPort.h"
+#include <winreg.h>
+#include <winnt.h>
+#include <winbase.h>
+
+/*
+ * The following declaration is a workaround for some Microsoft brain damage.
+ * The SYSTEM_INFO structure is different in various releases, even though the
+ * layout is the same. So we overlay our own structure on top of it so we
+ * can access the interesting slots in a uniform way.
+ */
+
+typedef struct {
+ WORD wProcessorArchitecture;
+ WORD wReserved;
+} OemId;
+
+/*
+ * The following macros are missing from some versions of winnt.h.
+ */
+
+#ifndef PROCESSOR_ARCHITECTURE_INTEL
+#define PROCESSOR_ARCHITECTURE_INTEL 0
+#endif
+#ifndef PROCESSOR_ARCHITECTURE_MIPS
+#define PROCESSOR_ARCHITECTURE_MIPS 1
+#endif
+#ifndef PROCESSOR_ARCHITECTURE_ALPHA
+#define PROCESSOR_ARCHITECTURE_ALPHA 2
+#endif
+#ifndef PROCESSOR_ARCHITECTURE_PPC
+#define PROCESSOR_ARCHITECTURE_PPC 3
+#endif
+#ifndef PROCESSOR_ARCHITECTURE_UNKNOWN
+#define PROCESSOR_ARCHITECTURE_UNKNOWN 0xFFFF
+#endif
+
+/*
+ * The following arrays contain the human readable strings for the Windows
+ * platform and processor values.
+ */
+
+
+#define NUMPLATFORMS 3
+static char* platforms[NUMPLATFORMS] = {
+ "Win32s", "Windows 95", "Windows NT"
+};
+
+#define NUMPROCESSORS 4
+static char* processors[NUMPROCESSORS] = {
+ "intel", "mips", "alpha", "ppc"
+};
+
+/*
+ * The following string is the startup script executed in new
+ * interpreters. It looks on disk in several different directories
+ * for a script "init.tcl" that is compatible with this version
+ * of Tcl. The init.tcl script does all of the real work of
+ * initialization.
+ */
+
+static char *initScript =
+"proc init {} {\n\
+ global tcl_library tcl_platform tcl_version tcl_patchLevel env errorInfo\n\
+ global tcl_pkgPath\n\
+ rename init {}\n\
+ set errors {}\n\
+ proc tcl_envTraceProc {lo n1 n2 op} {\n\
+ global env\n\
+ set x $env($n2)\n\
+ set env($lo) $x\n\
+ set env([string toupper $lo]) $x\n\
+ }\n\
+ foreach p [array names env] {\n\
+ set u [string toupper $p]\n\
+ if {$u != $p} {\n\
+ switch -- $u {\n\
+ COMSPEC -\n\
+ PATH {\n\
+ if {![info exists env($u)]} {\n\
+ set env($u) $env($p)\n\
+ }\n\
+ trace variable env($p) w [list tcl_envTraceProc $p]\n\
+ trace variable env($u) w [list tcl_envTraceProc $p]\n\
+ }\n\
+ }\n\
+ }\n\
+ }\n\
+ if {![info exists env(COMSPEC)]} {\n\
+ if {$tcl_platform(os) == {Windows NT}} {\n\
+ set env(COMSPEC) cmd.exe\n\
+ } else {\n\
+ set env(COMSPEC) command.com\n\
+ }\n\
+ } \n\
+ set dirs {}\n\
+ if {[info exists env(TCL_LIBRARY)]} {\n\
+ lappend dirs $env(TCL_LIBRARY)\n\
+ }\n\
+ lappend dirs $tcl_library\n\
+ lappend dirs [file join [file dirname [file dirname [info nameofexecutable]]] lib/tcl$tcl_version]\n\
+ if [string match {*[ab]*} $tcl_patchLevel] {\n\
+ set lib tcl$tcl_patchLevel\n\
+ } else {\n\
+ set lib tcl$tcl_version\n\
+ }\n\
+ lappend dirs [file join [file dirname [file dirname [pwd]]] $lib/library]\n\
+ lappend dirs [file join [file dirname [pwd]] library]\n\
+ foreach i $dirs {\n\
+ set tcl_library $i\n\
+ set tclfile [file join $i init.tcl]\n\
+ if {[file exists $tclfile]} {\n\
+ lappend tcl_pkgPath [file dirname $i]\n\
+ if ![catch {uplevel #0 [list source $tclfile]} msg] {\n\
+ return\n\
+ } else {\n\
+ append errors \"$tclfile: $msg\n$errorInfo\n\"\n\
+ }\n\
+ }\n\
+ }\n\
+ set msg \"Can't find a usable init.tcl in the following directories: \n\"\n\
+ append msg \" $dirs\n\n\"\n\
+ append msg \"$errors\n\n\"\n\
+ append msg \"This probably means that Tcl wasn't installed properly.\n\"\n\
+ error $msg\n\
+}\n\
+init\n";
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclPlatformInit --
+ *
+ * Performs Windows-specific interpreter initialization related to the
+ * tcl_library variable. Also sets up the HOME environment variable
+ * if it is not already set.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Sets "tcl_library" and "env(HOME)" Tcl variables
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclPlatformInit(interp)
+ Tcl_Interp *interp;
+{
+ char *ptr;
+ char buffer[13];
+ Tcl_DString ds;
+ OSVERSIONINFO osInfo;
+ SYSTEM_INFO sysInfo;
+ int isWin32s; /* True if we are running under Win32s. */
+ OemId *oemId;
+ HKEY key;
+ DWORD size;
+
+ tclPlatform = TCL_PLATFORM_WINDOWS;
+
+ Tcl_DStringInit(&ds);
+
+ /*
+ * Find out what kind of system we are running on.
+ */
+
+ osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
+ GetVersionEx(&osInfo);
+
+ isWin32s = (osInfo.dwPlatformId == VER_PLATFORM_WIN32s);
+
+ /*
+ * Since Win32s doesn't support GetSystemInfo, we use a default value.
+ */
+
+ oemId = (OemId *) &sysInfo;
+ if (!isWin32s) {
+ GetSystemInfo(&sysInfo);
+ } else {
+ oemId->wProcessorArchitecture = PROCESSOR_ARCHITECTURE_INTEL;
+ }
+
+ /*
+ * Initialize the tcl_library variable from the registry.
+ */
+
+ if (!isWin32s) {
+ if ((RegOpenKeyEx(HKEY_LOCAL_MACHINE,
+ "Software\\Sun\\Tcl\\" TCL_VERSION, 0, KEY_READ, &key)
+ == ERROR_SUCCESS)
+ && (RegQueryValueEx(key, "Root", NULL, NULL, NULL, &size)
+ == ERROR_SUCCESS)) {
+ Tcl_DStringSetLength(&ds, size);
+ RegQueryValueEx(key, "Root", NULL, NULL,
+ (LPBYTE)Tcl_DStringValue(&ds), &size);
+ }
+ } else {
+ if ((RegOpenKeyEx(HKEY_CLASSES_ROOT,
+ "Software\\Sun\\Tcl\\" TCL_VERSION, 0, KEY_READ, &key)
+ == ERROR_SUCCESS)
+ && (RegQueryValueEx(key, "", NULL, NULL, NULL, &size)
+ == ERROR_SUCCESS)) {
+ Tcl_DStringSetLength(&ds, size);
+ RegQueryValueEx(key, "", NULL, NULL,
+ (LPBYTE) Tcl_DStringValue(&ds), &size);
+ }
+ }
+ Tcl_SetVar(interp, "tcl_library", Tcl_DStringValue(&ds), TCL_GLOBAL_ONLY);
+ if (Tcl_DStringLength(&ds) > 0) {
+ char *argv[3];
+ argv[0] = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
+ argv[1] = "lib";
+ argv[2] = NULL;
+ Tcl_DStringSetLength(&ds, 0);
+ Tcl_SetVar(interp, "tcl_pkgPath", Tcl_JoinPath(2, argv, &ds),
+ TCL_GLOBAL_ONLY|TCL_LIST_ELEMENT);
+ argv[1] = "lib/tcl" TCL_VERSION;
+ Tcl_DStringSetLength(&ds, 0);
+ Tcl_SetVar(interp, "tcl_library", Tcl_JoinPath(2, argv, &ds),
+ TCL_GLOBAL_ONLY);
+ }
+
+ /*
+ * Define the tcl_platform array.
+ */
+
+ Tcl_SetVar2(interp, "tcl_platform", "platform", "windows",
+ TCL_GLOBAL_ONLY);
+ if (osInfo.dwPlatformId < NUMPLATFORMS) {
+ Tcl_SetVar2(interp, "tcl_platform", "os",
+ platforms[osInfo.dwPlatformId], TCL_GLOBAL_ONLY);
+ }
+ sprintf(buffer, "%d.%d", osInfo.dwMajorVersion, osInfo.dwMinorVersion);
+ Tcl_SetVar2(interp, "tcl_platform", "osVersion", buffer, TCL_GLOBAL_ONLY);
+ if (oemId->wProcessorArchitecture < NUMPROCESSORS) {
+ Tcl_SetVar2(interp, "tcl_platform", "machine",
+ processors[oemId->wProcessorArchitecture],
+ TCL_GLOBAL_ONLY);
+ }
+
+ /*
+ * Set up the HOME environment variable from the HOMEDRIVE & HOMEPATH
+ * environment variables, if necessary.
+ */
+
+ ptr = Tcl_GetVar2(interp, "env", "HOME", TCL_GLOBAL_ONLY);
+ if (ptr == NULL) {
+ Tcl_DStringSetLength(&ds, 0);
+ ptr = Tcl_GetVar2(interp, "env", "HOMEDRIVE", TCL_GLOBAL_ONLY);
+ if (ptr != NULL) {
+ Tcl_DStringAppend(&ds, ptr, -1);
+ }
+ ptr = Tcl_GetVar2(interp, "env", "HOMEPATH", TCL_GLOBAL_ONLY);
+ if (ptr != NULL) {
+ Tcl_DStringAppend(&ds, ptr, -1);
+ }
+ if (Tcl_DStringLength(&ds) > 0) {
+ Tcl_SetVar2(interp, "env", "HOME", Tcl_DStringValue(&ds),
+ TCL_GLOBAL_ONLY);
+ } else {
+ Tcl_SetVar2(interp, "env", "HOME", "c:\\", TCL_GLOBAL_ONLY);
+ }
+ }
+
+ Tcl_DStringFree(&ds);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_Init --
+ *
+ * This procedure is typically invoked by Tcl_AppInit procedures
+ * to perform additional initialization for a Tcl interpreter,
+ * such as sourcing the "init.tcl" script.
+ *
+ * Results:
+ * Returns a standard Tcl completion code and sets interp->result
+ * if there is an error.
+ *
+ * Side effects:
+ * Depends on what's in the init.tcl script.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_Init(interp)
+ Tcl_Interp *interp; /* Interpreter to initialize. */
+{
+ return Tcl_Eval(interp, initScript);
+
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclWinGetPlatform --
+ *
+ * This is a kludge that allows the test library to get access
+ * the internal tclPlatform variable.
+ *
+ * Results:
+ * Returns a pointer to the tclPlatform variable.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+TclPlatformType *
+TclWinGetPlatform()
+{
+ return &tclPlatform;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SourceRCFile --
+ *
+ * This procedure is typically invoked by Tcl_Main of Tk_Main
+ * procedure to source an application specific rc file into the
+ * interpreter at startup time.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Depends on what's in the rc script.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_SourceRCFile(interp)
+ Tcl_Interp *interp; /* Interpreter to source rc file into. */
+{
+ Tcl_DString temp;
+ char *fileName;
+ Tcl_Channel errChannel;
+
+ fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY);
+
+ if (fileName != NULL) {
+ Tcl_Channel c;
+ char *fullName;
+
+ Tcl_DStringInit(&temp);
+ fullName = Tcl_TranslateFileName(interp, fileName, &temp);
+ if (fullName == NULL) {
+ /*
+ * Couldn't translate the file name (e.g. it referred to a
+ * bogus user or there was no HOME environment variable).
+ * Just do nothing.
+ */
+ } else {
+
+ /*
+ * Test for the existence of the rc file before trying to read it.
+ */
+
+ c = Tcl_OpenFileChannel(NULL, fullName, "r", 0);
+ if (c != (Tcl_Channel) NULL) {
+ Tcl_Close(NULL, c);
+ if (Tcl_EvalFile(interp, fullName) != TCL_OK) {
+ errChannel = Tcl_GetStdChannel(TCL_STDERR);
+ if (errChannel) {
+ Tcl_Write(errChannel, interp->result, -1);
+ Tcl_Write(errChannel, "\n", 1);
+ }
+ }
+ }
+ }
+ Tcl_DStringFree(&temp);
+ }
+}
diff --git a/win/tclWinInt.h b/win/tclWinInt.h
new file mode 100644
index 0000000..04e84d6
--- /dev/null
+++ b/win/tclWinInt.h
@@ -0,0 +1,38 @@
+/*
+ * tclWinInt.h --
+ *
+ * Declarations of Windows-specific shared variables and procedures.
+ *
+ * Copyright (c) 1994-1996 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclWinInt.h 1.7 97/06/25 10:56:14
+ */
+
+#ifndef _TCLWININT
+#define _TCLWININT
+
+#ifndef _TCLINT
+#include "tclInt.h"
+#endif
+#ifndef _TCLPORT
+#include "tclPort.h"
+#endif
+
+/*
+ * Some versions of Borland C have a define for the OSVERSIONINFO for
+ * Win32s and for NT, but not for Windows 95.
+ */
+
+#ifndef VER_PLATFORM_WIN32_WINDOWS
+#define VER_PLATFORM_WIN32_WINDOWS 1
+#endif
+
+EXTERN int TclWinSynchSpawn(void *args, int type, void **trans,
+ Tcl_Pid *pidPtr);
+EXTERN int TclWinGetPlatformId(void);
+
+
+#endif /* _TCLWININT */
diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c
new file mode 100644