Tcl Source Code

Changes On Branch tip-603
Login
Bounty program for improvements to Tcl and certain Tcl packages.

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

Changes In Branch tip-603 Excluding Merge-Ins

This is equivalent to a diff from 6320599e4f to 488d60d3f7

2022-09-22
15:35
Merge 8.6 check-in: 9b276ec12e user: jan.nijtmans tags: core-8-branch
13:38
merge 8.7 check-in: db70520b89 user: dgp tags: tip-getnumber
12:50
rebase to latest 8.7 Leaf check-in: 488d60d3f7 user: jan.nijtmans tags: tip-603
12:46
rebase to latest 8.7 check-in: 71e02f94a7 user: jan.nijtmans tags: tip-344
12:40
Merge 8.7 check-in: 55a6ac3c05 user: jan.nijtmans tags: trunk, main
12:32
Merge 8.6 check-in: 6320599e4f user: jan.nijtmans tags: core-8-branch
12:30
Fix [22ab2ae64a]: Build with minizip broken (actually, only a problem in 8.7, but let's keep tinydir... check-in: 696144dced user: jan.nijtmans tags: core-8-6-branch
2022-09-21
13:08
Merge 8.6 check-in: 6979bf518d user: jan.nijtmans tags: core-8-branch
2021-11-01
16:28
Merge 8.7 check-in: 3842ac8331 user: jan.nijtmans tags: tip-603

Changes to doc/open.n.

124
125
126
127
128
129
130






















131
132
133
134
135
136
137
.
If the file exists it is truncated to zero length.
.PP
If a new file is created as part of opening it, \fIpermissions\fR
(an integer) is used to set the permissions for the new file in
conjunction with the process's file mode creation mask.
\fIPermissions\fR defaults to 0666.






















.SH "COMMAND PIPELINES"
.PP
If the first character of \fIfileName\fR is
.QW \fB|\fR
then the
remaining characters of \fIfileName\fR are treated as a list of arguments
that describe a command pipeline to invoke, in the same style as the






>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







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
.
If the file exists it is truncated to zero length.
.PP
If a new file is created as part of opening it, \fIpermissions\fR
(an integer) is used to set the permissions for the new file in
conjunction with the process's file mode creation mask.
\fIPermissions\fR defaults to 0666.
.PP
.VS "8.7, TIP 603"
When the file opened is an ordinary disk file, the \fBchan configure\fR and
\fBfconfigure\fR commands can be used to query this additional configuration
option:
.TP
\fB\-stat\fR
.
This option, when read, returns a dictionary of values much as is obtained
from the \fBfile stat\fR command, where that stat information relates to the
real opened file. Keys in the dictionary may include \fBatime\fR, \fBctime\fR,
\fBdev\fR, \fBgid\fR, \fBino\fR, \fBmode\fR, \fBmtime\fR, \fBnlink\fR,
\fBsize\fR, \fBtype\fR, and \fBuid\fR among others; the \fBmtime\fR,
\fBsize\fR and \fBtype\fR fields are guaranteed to be present and meaningful
on all platforms; other keys may be present too.
.RS
.PP
\fIImplementation note:\fR This option maps to a call to \fBfstat()\fR on
POSIX platforms, and to a call to \fBGetFileInformationByHandle()\fR on
Windows; the information reported is what those system calls produce.
.RE
.VE "8.7, TIP 603"
.SH "COMMAND PIPELINES"
.PP
If the first character of \fIfileName\fR is
.QW \fB|\fR
then the
remaining characters of \fIfileName\fR are treated as a list of arguments
that describe a command pipeline to invoke, in the same style as the

Changes to generic/tclCmdAH.c.

2408
2409
2410
2411
2412
2413
2414
2415





2416
2417

2418
2419
2420
2421
2422
2423
2424
    STORE_ARY("gid",	Tcl_NewWideIntObj((long)statPtr->st_gid));
    STORE_ARY("size",	Tcl_NewWideIntObj(statPtr->st_size));
#ifdef HAVE_STRUCT_STAT_ST_BLOCKS
    STORE_ARY("blocks",	Tcl_NewWideIntObj(statPtr->st_blocks));
#endif
#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
    STORE_ARY("blksize", Tcl_NewWideIntObj((long)statPtr->st_blksize));
#endif





    STORE_ARY("atime",	Tcl_NewWideIntObj(Tcl_GetAccessTimeFromStat(statPtr)));
    STORE_ARY("mtime",	Tcl_NewWideIntObj(Tcl_GetModificationTimeFromStat(statPtr)));

    STORE_ARY("ctime",	Tcl_NewWideIntObj(Tcl_GetChangeTimeFromStat(statPtr)));
    mode = (unsigned short) statPtr->st_mode;
    STORE_ARY("mode",	Tcl_NewWideIntObj(mode));
    STORE_ARY("type",	Tcl_NewStringObj(GetTypeFromMode(mode), -1));
#undef STORE_ARY

    return TCL_OK;







>
>
>
>
>

|
>







2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
    STORE_ARY("gid",	Tcl_NewWideIntObj((long)statPtr->st_gid));
    STORE_ARY("size",	Tcl_NewWideIntObj(statPtr->st_size));
#ifdef HAVE_STRUCT_STAT_ST_BLOCKS
    STORE_ARY("blocks",	Tcl_NewWideIntObj(statPtr->st_blocks));
#endif
#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
    STORE_ARY("blksize", Tcl_NewWideIntObj((long)statPtr->st_blksize));
#endif
#ifdef HAVE_STRUCT_STAT_ST_RDEV
    if (S_ISCHR(statPtr->st_mode) || S_ISBLK(statPtr->st_mode)) {
	STORE_ARY("rdev", Tcl_NewWideIntObj((long) statPtr->st_rdev));
    }
#endif
    STORE_ARY("atime",	Tcl_NewWideIntObj(Tcl_GetAccessTimeFromStat(statPtr)));
    STORE_ARY("mtime",	Tcl_NewWideIntObj(
	    Tcl_GetModificationTimeFromStat(statPtr)));
    STORE_ARY("ctime",	Tcl_NewWideIntObj(Tcl_GetChangeTimeFromStat(statPtr)));
    mode = (unsigned short) statPtr->st_mode;
    STORE_ARY("mode",	Tcl_NewWideIntObj(mode));
    STORE_ARY("type",	Tcl_NewStringObj(GetTypeFromMode(mode), -1));
#undef STORE_ARY

    return TCL_OK;

Changes to tests/ioCmd.test.

226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
test iocmd-8.4 {fconfigure command} -setup {
    file delete $path(test1)
    set f1 [open $path(test1) w]
} -body {
    fconfigure $f1 froboz
} -returnCodes error -cleanup {
    close $f1
} -result [expectedOpts "froboz" {}]
test iocmd-8.5 {fconfigure command} -returnCodes error -body {
    fconfigure stdin -buffering froboz
} -result {bad value for -buffering: must be one of full, line, or none}
test iocmd-8.6 {fconfigure command} -returnCodes error -body {
    fconfigure stdin -translation froboz
} -result {bad value for -translation: must be one of auto, binary, cr, lf, crlf, or platform}
test iocmd-8.7 {fconfigure command} -setup {






|







226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
test iocmd-8.4 {fconfigure command} -setup {
    file delete $path(test1)
    set f1 [open $path(test1) w]
} -body {
    fconfigure $f1 froboz
} -returnCodes error -cleanup {
    close $f1
} -result [expectedOpts "froboz" -stat]
test iocmd-8.5 {fconfigure command} -returnCodes error -body {
    fconfigure stdin -buffering froboz
} -result {bad value for -buffering: must be one of full, line, or none}
test iocmd-8.6 {fconfigure command} -returnCodes error -body {
    fconfigure stdin -translation froboz
} -result {bad value for -translation: must be one of auto, binary, cr, lf, crlf, or platform}
test iocmd-8.7 {fconfigure command} -setup {
578
579
580
581
582
583
584
585





















586
587
588
589
590
591
592
    set fid [open $f rb]
    append d [read $fid]
    close $fid
    return $d
} -cleanup {
    removeFile $f
} -result 341234x6























test iocmd-14.1 {file id parsing errors} {
    list [catch {eof gorp} msg] $msg $::errorCode
} {1 {can not find channel named "gorp"} {TCL LOOKUP CHANNEL gorp}}
test iocmd-14.2 {file id parsing errors} {
    list [catch {eof filex} msg] $msg
} {1 {can not find channel named "filex"}}






|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







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
    set fid [open $f rb]
    append d [read $fid]
    close $fid
    return $d
} -cleanup {
    removeFile $f
} -result 341234x6
test ioCmd-13.12 {open file produces something that has fconfigure -stat} -setup {
    set f [makeFile {} iocmd13_12]
    set result {}
} -body {
    set fd [open $f wb]
    set result [dict get [fconfigure $fd -stat] type]
    fconfigure $fd -buffering none
    puts -nonewline $fd abc
    # Three ways of getting the size; all should agree!
    lappend result [tell $fd] [file size $f] \
	[dict get [fconfigure $fd -stat] size]
    puts -nonewline $fd def
    lappend result [tell $fd] [file size $f] \
	[dict get [fconfigure $fd -stat] size]
    puts -nonewline $fd ghi
    lappend result [tell $fd] [file size $f] \
	[dict get [fconfigure $fd -stat] size]
    close $fd
    return $result
} -cleanup {
    removeFile $f
} -result {file 3 3 3 6 6 6 9 9 9}

test iocmd-14.1 {file id parsing errors} {
    list [catch {eof gorp} msg] $msg $::errorCode
} {1 {can not find channel named "gorp"} {TCL LOOKUP CHANNEL gorp}}
test iocmd-14.2 {file id parsing errors} {
    list [catch {eof filex} msg] $msg
} {1 {can not find channel named "filex"}}

Changes to unix/configure.

9518
9519
9520
9521
9522
9523
9524








9525
9526
9527
9528
9529
9530
9531
fi
ac_fn_c_check_member "$LINENO" "struct stat" "st_blksize" "ac_cv_member_struct_stat_st_blksize" "$ac_includes_default"
if test "x$ac_cv_member_struct_stat_st_blksize" = xyes
then :

printf "%s\n" "#define HAVE_STRUCT_STAT_ST_BLKSIZE 1" >>confdefs.h










fi

fi
ac_fn_c_check_type "$LINENO" "blkcnt_t" "ac_cv_type_blkcnt_t" "$ac_includes_default"
if test "x$ac_cv_type_blkcnt_t" = xyes
then :






>
>
>
>
>
>
>
>







9518
9519
9520
9521
9522
9523
9524
9525
9526
9527
9528
9529
9530
9531
9532
9533
9534
9535
9536
9537
9538
9539
fi
ac_fn_c_check_member "$LINENO" "struct stat" "st_blksize" "ac_cv_member_struct_stat_st_blksize" "$ac_includes_default"
if test "x$ac_cv_member_struct_stat_st_blksize" = xyes
then :

printf "%s\n" "#define HAVE_STRUCT_STAT_ST_BLKSIZE 1" >>confdefs.h


fi
ac_fn_c_check_member "$LINENO" "struct stat" "st_rdev" "ac_cv_member_struct_stat_st_rdev" "$ac_includes_default"
if test "x$ac_cv_member_struct_stat_st_rdev" = xyes
then :

printf "%s\n" "#define HAVE_STRUCT_STAT_ST_RDEV 1" >>confdefs.h


fi

fi
ac_fn_c_check_type "$LINENO" "blkcnt_t" "ac_cv_type_blkcnt_t" "$ac_includes_default"
if test "x$ac_cv_type_blkcnt_t" = xyes
then :

Changes to unix/configure.ac.

364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
#--------------------------------------------------------------------
#	Some systems (e.g., IRIX 4.0.5) lack some fields in struct stat. But
#	we might be able to use fstatfs instead. Some systems (OpenBSD?) also
#	lack blkcnt_t.
#--------------------------------------------------------------------

if test "$ac_cv_cygwin" != "yes"; then
    AC_CHECK_MEMBERS([struct stat.st_blocks, struct stat.st_blksize])
fi
AC_CHECK_TYPES([blkcnt_t])
AC_CHECK_FUNC(fstatfs, , [AC_DEFINE(NO_FSTATFS, 1, [Do we have fstatfs()?])])

#--------------------------------------------------------------------
#       Some system have no memcmp or it does not work with 8 bit data, this
#       checks it and add memcmp.o to LIBOBJS if needed






|







364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
#--------------------------------------------------------------------
#	Some systems (e.g., IRIX 4.0.5) lack some fields in struct stat. But
#	we might be able to use fstatfs instead. Some systems (OpenBSD?) also
#	lack blkcnt_t.
#--------------------------------------------------------------------

if test "$ac_cv_cygwin" != "yes"; then
    AC_CHECK_MEMBERS([struct stat.st_blocks, struct stat.st_blksize, struct stat.st_rdev])
fi
AC_CHECK_TYPES([blkcnt_t])
AC_CHECK_FUNC(fstatfs, , [AC_DEFINE(NO_FSTATFS, 1, [Do we have fstatfs()?])])

#--------------------------------------------------------------------
#       Some system have no memcmp or it does not work with 8 bit data, this
#       checks it and add memcmp.o to LIBOBJS if needed

Changes to unix/tclUnixChan.c.

120
121
122
123
124
125
126



127
128
129
130
131
132
133
 */

static int		FileBlockModeProc(void *instanceData, int mode);
static int		FileCloseProc(void *instanceData,
			    Tcl_Interp *interp, int flags);
static int		FileGetHandleProc(void *instanceData,
			    int direction, void **handlePtr);



static int		FileInputProc(void *instanceData, char *buf,
			    int toRead, int *errorCode);
static int		FileOutputProc(void *instanceData,
			    const char *buf, int toWrite, int *errorCode);
#ifndef TCL_NO_DEPRECATED
static int		FileSeekProc(void *instanceData, long offset,
			    int mode, int *errorCode);






>
>
>







120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
 */

static int		FileBlockModeProc(void *instanceData, int mode);
static int		FileCloseProc(void *instanceData,
			    Tcl_Interp *interp, int flags);
static int		FileGetHandleProc(void *instanceData,
			    int direction, void **handlePtr);
static int		FileGetOptionProc(void *instanceData,
			    Tcl_Interp *interp, const char *optionName,
			    Tcl_DString *dsPtr);
static int		FileInputProc(void *instanceData, char *buf,
			    int toRead, int *errorCode);
static int		FileOutputProc(void *instanceData,
			    const char *buf, int toWrite, int *errorCode);
#ifndef TCL_NO_DEPRECATED
static int		FileSeekProc(void *instanceData, long offset,
			    int mode, int *errorCode);
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
    FileOutputProc,		/* Output proc. */
#ifndef TCL_NO_DEPRECATED
    FileSeekProc,		/* Seek proc. */
#else
	NULL,
#endif
    NULL,			/* Set option proc. */
    NULL,			/* Get option proc. */
    FileWatchProc,		/* Initialize notifier. */
    FileGetHandleProc,		/* Get OS handles out of channel. */
    FileCloseProc,		/* close2proc. */
    FileBlockModeProc,		/* Set blocking or non-blocking mode.*/
    NULL,			/* flush proc. */
    NULL,			/* handler proc. */
    FileWideSeekProc,		/* wide seek proc. */






|







171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
    FileOutputProc,		/* Output proc. */
#ifndef TCL_NO_DEPRECATED
    FileSeekProc,		/* Seek proc. */
#else
	NULL,
#endif
    NULL,			/* Set option proc. */
    FileGetOptionProc,		/* Get option proc. */
    FileWatchProc,		/* Initialize notifier. */
    FileGetHandleProc,		/* Get OS handles out of channel. */
    FileCloseProc,		/* close2proc. */
    FileBlockModeProc,		/* Set blocking or non-blocking mode.*/
    NULL,			/* flush proc. */
    NULL,			/* handler proc. */
    FileWideSeekProc,		/* wide seek proc. */
598
599
600
601
602
603
604










































































































































































605
606
607
608
609
610
611
    if (direction & fsPtr->validMask) {
	*handlePtr = INT2PTR(fsPtr->fd);
	return TCL_OK;
    }
    return TCL_ERROR;
}











































































































































































#ifdef SUPPORTS_TTY
/*
 *----------------------------------------------------------------------
 *
 * TtyModemStatusStr --
 *






>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







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
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
    if (direction & fsPtr->validMask) {
	*handlePtr = INT2PTR(fsPtr->fd);
	return TCL_OK;
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * FileGetOptionProc --
 *
 *	Gets an option associated with an open file. 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.  Sets error message if needed
 *	(by calling Tcl_BadChannelOption).
 *
 *----------------------------------------------------------------------
 */

static inline void
StoreElementInDict(
    Tcl_Obj *dictObj,
    const char *name,
    Tcl_Obj *valueObj)
{
    /*
     * We assume that the dict is being built fresh and that there's never any
     * duplicate keys.
     */

    Tcl_Obj *nameObj = Tcl_NewStringObj(name, -1);
    Tcl_DictObjPut(NULL, dictObj, nameObj, valueObj);
}

static inline const char *
GetTypeFromMode(
    int mode)
{
    /*
     * TODO: deduplicate with tclCmdAH.c
     */

    if (S_ISREG(mode)) {
	return "file";
    } else if (S_ISDIR(mode)) {
	return "directory";
    } else if (S_ISCHR(mode)) {
	return "characterSpecial";
    } else if (S_ISBLK(mode)) {
	return "blockSpecial";
    } else if (S_ISFIFO(mode)) {
	return "fifo";
#ifdef S_ISLNK
    } else if (S_ISLNK(mode)) {
	return "link";
#endif
#ifdef S_ISSOCK
    } else if (S_ISSOCK(mode)) {
	return "socket";
#endif
    }
    return "unknown";
}

static Tcl_Obj *
StatOpenFile(
    FileState *fsPtr)
{
    Tcl_StatBuf statBuf;	/* Not allocated on heap; we're definitely
				 * API-synchronized with how Tcl is built! */
    Tcl_Obj *dictObj;
    unsigned short mode;

    if (TclOSfstat(fsPtr->fd, &statBuf) < 0) {
	return NULL;
    }

    /*
     * TODO: merge with TIP 594 implementation (it's silly to have a
     * duplicate!)
     */

    dictObj = Tcl_NewObj();
#define STORE_ELEM(name, value) StoreElementInDict(dictObj, name, value)

    STORE_ELEM("dev",     Tcl_NewWideIntObj((long) statBuf.st_dev));
    STORE_ELEM("ino",     Tcl_NewWideIntObj((Tcl_WideInt) statBuf.st_ino));
    STORE_ELEM("nlink",   Tcl_NewWideIntObj((long) statBuf.st_nlink));
    STORE_ELEM("uid",     Tcl_NewWideIntObj((long) statBuf.st_uid));
    STORE_ELEM("gid",     Tcl_NewWideIntObj((long) statBuf.st_gid));
    STORE_ELEM("size",    Tcl_NewWideIntObj((Tcl_WideInt) statBuf.st_size));
#ifdef HAVE_STRUCT_STAT_ST_BLOCKS
    STORE_ELEM("blocks",  Tcl_NewWideIntObj((Tcl_WideInt) statBuf.st_blocks));
#endif
#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
    STORE_ELEM("blksize", Tcl_NewWideIntObj((long) statBuf.st_blksize));
#endif
#ifdef HAVE_STRUCT_STAT_ST_RDEV
    if (S_ISCHR(statBuf.st_mode) || S_ISBLK(statBuf.st_mode)) {
	STORE_ELEM("rdev", Tcl_NewWideIntObj((long) statBuf.st_rdev));
    }
#endif
    STORE_ELEM("atime",   Tcl_NewWideIntObj(
	    Tcl_GetAccessTimeFromStat(&statBuf)));
    STORE_ELEM("mtime",   Tcl_NewWideIntObj(
	    Tcl_GetModificationTimeFromStat(&statBuf)));
    STORE_ELEM("ctime",   Tcl_NewWideIntObj(
	    Tcl_GetChangeTimeFromStat(&statBuf)));
    mode = (unsigned short) statBuf.st_mode;
    STORE_ELEM("mode",    Tcl_NewWideIntObj(mode));
    STORE_ELEM("type",    Tcl_NewStringObj(GetTypeFromMode(mode), -1));
#undef STORE_ELEM

    return dictObj;
}

static int
FileGetOptionProc(
    void *instanceData,
    Tcl_Interp *interp,
    const char *optionName,
    Tcl_DString *dsPtr)
{
    FileState *fsPtr = (FileState *)instanceData;
    int valid = 0;		/* Flag if valid option parsed. */
    int len;

    if (optionName == NULL) {
	len = 0;
	valid = 1;
    } else {
	len = strlen(optionName);
    }

    /*
     * Get option -stat
     * Option is readonly and returned by [fconfigure chan -stat] but not
     * returned by [fconfigure chan] without explicit option name.
     */

    if ((len > 1) && (strncmp(optionName, "-stat", len) == 0)) {
	Tcl_Obj *dictObj = StatOpenFile(fsPtr);
	const char *dictContents;
	int dictLength;

	if (dictObj == NULL) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "couldn't read file channel status: %s",
		    Tcl_PosixError(interp)));
	    return TCL_ERROR;
	}

	/*
	 * Transfer dictionary to the DString. Note that we don't do this as
	 * an element as this is an option that can't be retrieved with a
	 * general probe.
	 */

	dictContents = Tcl_GetStringFromObj(dictObj, &dictLength);
	Tcl_DStringAppend(dsPtr, dictContents, dictLength);
	Tcl_DecrRefCount(dictObj);
	return TCL_OK;
    }

    if (valid) {
	return TCL_OK;
    }
    return Tcl_BadChannelOption(interp, optionName,
		"stat");
}

#ifdef SUPPORTS_TTY
/*
 *----------------------------------------------------------------------
 *
 * TtyModemStatusStr --
 *

Changes to win/tclWinChan.c.

76
77
78
79
80
81
82



83
84
85
86
87
88
89
static void		FileChannelExitHandler(ClientData clientData);
static void		FileCheckProc(ClientData clientData, int flags);
static int		FileCloseProc(ClientData instanceData,
			    Tcl_Interp *interp, int flags);
static int		FileEventProc(Tcl_Event *evPtr, int flags);
static int		FileGetHandleProc(ClientData instanceData,
			    int direction, ClientData *handlePtr);



static ThreadSpecificData *FileInit(void);
static int		FileInputProc(ClientData instanceData, char *buf,
			    int toRead, int *errorCode);
static int		FileOutputProc(ClientData instanceData,
			    const char *buf, int toWrite, int *errorCode);
#ifndef TCL_NO_DEPRECATED
static int		FileSeekProc(ClientData instanceData, long offset,






>
>
>







76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
static void		FileChannelExitHandler(ClientData clientData);
static void		FileCheckProc(ClientData clientData, int flags);
static int		FileCloseProc(ClientData instanceData,
			    Tcl_Interp *interp, int flags);
static int		FileEventProc(Tcl_Event *evPtr, int flags);
static int		FileGetHandleProc(ClientData instanceData,
			    int direction, ClientData *handlePtr);
static int		FileGetOptionProc(ClientData instanceData,
			    Tcl_Interp *interp, const char *optionName,
			    Tcl_DString *dsPtr);
static ThreadSpecificData *FileInit(void);
static int		FileInputProc(ClientData instanceData, char *buf,
			    int toRead, int *errorCode);
static int		FileOutputProc(ClientData instanceData,
			    const char *buf, int toWrite, int *errorCode);
#ifndef TCL_NO_DEPRECATED
static int		FileSeekProc(ClientData instanceData, long offset,
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
    FileOutputProc,		/* Output proc. */
#ifndef TCL_NO_DEPRECATED
    FileSeekProc,		/* Seek proc. */
#else
	NULL,
#endif
    NULL,			/* Set option proc. */
    NULL,			/* Get option proc. */
    FileWatchProc,		/* Set up the notifier to watch the channel. */
    FileGetHandleProc,		/* Get an OS handle from channel. */
    FileCloseProc,		/* close2proc. */
    FileBlockProc,		/* Set blocking or non-blocking mode.*/
    NULL,			/* flush proc. */
    NULL,			/* handler proc. */
    FileWideSeekProc,		/* Wide seek proc. */
    FileThreadActionProc,	/* Thread action proc. */
    FileTruncateProc		/* Truncate proc. */
};

/*
 * General useful clarification macros.
 */

#define SET_FLAG(var, flag)	((var) |= (flag))
#define CLEAR_FLAG(var, flag)	((var) &= ~(flag))
#define TEST_FLAG(value, flag)	(((value) & (flag)) != 0)










/*
 *----------------------------------------------------------------------
 *
 * FileInit --
 *
 *	This function creates the window used to simulate file events.






|


















>
>
>
>
>
>
>
>
>







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
    FileOutputProc,		/* Output proc. */
#ifndef TCL_NO_DEPRECATED
    FileSeekProc,		/* Seek proc. */
#else
	NULL,
#endif
    NULL,			/* Set option proc. */
    FileGetOptionProc,		/* Get option proc. */
    FileWatchProc,		/* Set up the notifier to watch the channel. */
    FileGetHandleProc,		/* Get an OS handle from channel. */
    FileCloseProc,		/* close2proc. */
    FileBlockProc,		/* Set blocking or non-blocking mode.*/
    NULL,			/* flush proc. */
    NULL,			/* handler proc. */
    FileWideSeekProc,		/* Wide seek proc. */
    FileThreadActionProc,	/* Thread action proc. */
    FileTruncateProc		/* Truncate proc. */
};

/*
 * General useful clarification macros.
 */

#define SET_FLAG(var, flag)	((var) |= (flag))
#define CLEAR_FLAG(var, flag)	((var) &= ~(flag))
#define TEST_FLAG(value, flag)	(((value) & (flag)) != 0)

/*
 * The number of 100-ns intervals between the Windows system epoch (1601-01-01
 * on the proleptic Gregorian calendar) and the Posix epoch (1970-01-01).
 */

#define POSIX_EPOCH_AS_FILETIME	\
	((long long) 116444736 * (long long) 1000000000)


/*
 *----------------------------------------------------------------------
 *
 * FileInit --
 *
 *	This function creates the window used to simulate file events.
826
827
828
829
830
831
832





























































































































































































833
834
835
836
837
838
839
    if (!TEST_FLAG(direction, infoPtr->validMask)) {
	return TCL_ERROR;
    }

    *handlePtr = (ClientData) infoPtr->handle;
    return TCL_OK;
}






























































































































































































/*
 *----------------------------------------------------------------------
 *
 * TclpOpenFileChannel --
 *
 *	Open an File based channel on Unix systems.






>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
    if (!TEST_FLAG(direction, infoPtr->validMask)) {
	return TCL_ERROR;
    }

    *handlePtr = (ClientData) infoPtr->handle;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * FileGetOptionProc --
 *
 *	Gets an option associated with an open file. 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.  Sets error message if needed
 *	(by calling Tcl_BadChannelOption).
 *
 *----------------------------------------------------------------------
 */

static inline ULONGLONG
CombineDwords(
    DWORD hi,
    DWORD lo)
{
    ULARGE_INTEGER converter;

    converter.LowPart = lo;
    converter.HighPart = hi;
    return converter.QuadPart;
}

static inline void
StoreElementInDict(
    Tcl_Obj *dictObj,
    const char *name,
    Tcl_Obj *valueObj)
{
    /*
     * We assume that the dict is being built fresh and that there's never any
     * duplicate keys.
     */

    Tcl_Obj *nameObj = Tcl_NewStringObj(name, -1);
    Tcl_DictObjPut(NULL, dictObj, nameObj, valueObj);
}

static inline time_t
ToCTime(
    FILETIME fileTime)		/* UTC time */
{
    LARGE_INTEGER convertedTime;

    convertedTime.LowPart = fileTime.dwLowDateTime;
    convertedTime.HighPart = (LONG) fileTime.dwHighDateTime;

    return (time_t) ((convertedTime.QuadPart -
	    (long long) POSIX_EPOCH_AS_FILETIME) / (long long) 10000000);
}

static Tcl_Obj *
StatOpenFile(
    FileInfo *infoPtr)
{
    DWORD attr;
    int dev, nlink = 1;
    unsigned short mode;
    unsigned long long size, inode;
    long long atime, ctime, mtime;
    BY_HANDLE_FILE_INFORMATION data;
    Tcl_Obj *dictObj;

    if (GetFileInformationByHandle(infoPtr->handle, &data) != TRUE) {
	Tcl_SetErrno(ENOENT);
	return NULL;
    }

    atime = ToCTime(data.ftLastAccessTime);
    mtime = ToCTime(data.ftLastWriteTime);
    ctime = ToCTime(data.ftCreationTime);
    attr = data.dwFileAttributes;
    size = CombineDwords(data.nFileSizeHigh, data.nFileSizeLow);
    nlink = data.nNumberOfLinks;

    /*
     * Unfortunately our stat definition's inode field (unsigned short) will
     * throw away most of the precision we have here, which means we can't
     * rely on inode as a unique identifier of a file. We'd really like to do
     * something like how we handle 'st_size'.
     */

    inode = CombineDwords(data.nFileIndexHigh, data.nFileIndexLow);

    dev = data.dwVolumeSerialNumber;

    /*
     * Note that this code has no idea whether the file can be executed.
     */

    mode = (attr & FILE_ATTRIBUTE_DIRECTORY) ? S_IFDIR|S_IEXEC : S_IFREG;
    mode |= (attr & FILE_ATTRIBUTE_READONLY) ? S_IREAD : S_IREAD|S_IWRITE;
    mode |= (mode & (S_IREAD|S_IWRITE|S_IEXEC)) >> 3;
    mode |= (mode & (S_IREAD|S_IWRITE|S_IEXEC)) >> 6;

    /*
     * We don't construct a Tcl_StatBuf; we're using the info immediately.
     */

    dictObj = Tcl_NewObj();
#define STORE_ELEM(name, value) StoreElementInDict(dictObj, name, value)

    STORE_ELEM("dev",      Tcl_NewWideIntObj((long) dev));
    STORE_ELEM("ino",      Tcl_NewWideIntObj((long long) inode));
    STORE_ELEM("nlink",    Tcl_NewIntObj(nlink));
    STORE_ELEM("uid",      Tcl_NewIntObj(0));
    STORE_ELEM("gid",      Tcl_NewIntObj(0));
    STORE_ELEM("size",     Tcl_NewWideIntObj((long long) size));
    STORE_ELEM("atime",    Tcl_NewWideIntObj(atime));
    STORE_ELEM("mtime",    Tcl_NewWideIntObj(mtime));
    STORE_ELEM("ctime",    Tcl_NewWideIntObj(ctime));
    STORE_ELEM("mode",     Tcl_NewWideIntObj(mode));

    /*
     * Windows only has files and directories, as far as we're concerned.
     * Anything else and we definitely couldn't have got here anyway.
     */
    if (attr & FILE_ATTRIBUTE_DIRECTORY) {
	STORE_ELEM("type", Tcl_NewStringObj("directory", -1));
    } else {
	STORE_ELEM("type", Tcl_NewStringObj("file", -1));
    }
#undef STORE_ELEM

    return dictObj;
}

static int
FileGetOptionProc(
    ClientData instanceData,	/* The file state. */
    Tcl_Interp *interp,		/* For error reporting. */
    const char *optionName,	/* What option to read, or NULL for all. */
    Tcl_DString *dsPtr)		/* Where to write the value read. */
{
    FileInfo *infoPtr = (FileInfo *)instanceData;
    int valid = 0;		/* Flag if valid option parsed. */
    int len;

    if (optionName == NULL) {
	len = 0;
	valid = 1;
    } else {
	len = strlen(optionName);
    }

    /*
     * Get option -stat
     * Option is readonly and returned by [fconfigure chan -stat] but not
     * returned by [fconfigure chan] without explicit option name.
     */

    if ((len > 1) && (strncmp(optionName, "-stat", len) == 0)) {
	return TCL_OK;
    }

    if (valid) {
	Tcl_Obj *dictObj = StatOpenFile(infoPtr);
	const char *dictContents;
	int dictLength;

	if (dictObj == NULL) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "couldn't read file channel status: %s",
		    Tcl_PosixError(interp)));
	    return TCL_ERROR;
	}

	/*
	 * Transfer dictionary to the DString. Note that we don't do this as
	 * an element as this is an option that can't be retrieved with a
	 * general probe.
	 */

	dictContents = Tcl_GetStringFromObj(dictObj, &dictLength);
	Tcl_DStringAppend(dsPtr, dictContents, dictLength);
	Tcl_DecrRefCount(dictObj);
	return TCL_OK;
    }
    return Tcl_BadChannelOption(interp, optionName,
		"stat");
}

/*
 *----------------------------------------------------------------------
 *
 * TclpOpenFileChannel --
 *
 *	Open an File based channel on Unix systems.