Tcl Source Code

Check-in [de6ff74610]
Login

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

Overview
Comment:merge 8.7
Downloads: Tarball | ZIP archive
Timelines: family | ancestors | descendants | both | core-8-7-a3-rc
Files: files | file ages | folders
SHA3-256: de6ff74610f0aca11a418c3c6aeb86e277d6580641436acdb74befbdf33d43fb
User & Date: dgp 2019-11-07 15:09:23.620
Context
2019-11-08
15:11
Start updates to changes check-in: 90b21061b1 user: dgp tags: core-8-7-a3-rc
2019-11-07
15:09
merge 8.7 check-in: de6ff74610 user: dgp tags: core-8-7-a3-rc
14:57
merge-mark check-in: efdcc25a5d user: jan.nijtmans tags: core-8-branch
2019-11-06
14:35
Merge 8.7. Add files missing from distribution. check-in: 28e86efc87 user: dgp tags: rc1, core-8-7-a3-rc
Changes
Unified Diff Ignore Whitespace Patch
Changes to generic/tcl.h.
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675

1676
1677
1678

1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720

1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767

1768
1769
1770
1771
1772

1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811




1812
1813
1814
1815
1816
1817
1818

#define TCL_FILESYSTEM_VERSION_1	((Tcl_FSVersion) 0x1)

/*
 * struct Tcl_Filesystem:
 *
 * One such structure exists for each type (kind) of filesystem. It collects
 * together in one place all the functions that are part of the specific
 * filesystem. Tcl always accesses the filesystem through one of these
 * structures.
 *
 * Not all entries need be non-NULL; any which are NULL are simply ignored.
 * However, a complete filesystem should provide all of these functions. The
 * explanations in the structure show the importance of each function.
 */

typedef struct Tcl_Filesystem {
    const char *typeName;	/* The name of the filesystem. */
    int structureLength;	/* Length of this structure, so future binary
				 * compatibility can be assured. */
    Tcl_FSVersion version;	/* Version of the filesystem type. */
    Tcl_FSPathInFilesystemProc *pathInFilesystemProc;
				/* Function to check whether a path is in this
				 * filesystem. This is the most important
				 * filesystem function. */
    Tcl_FSDupInternalRepProc *dupInternalRepProc;
				/* Function to duplicate internal fs rep. May

				 * be NULL (but then fs is less efficient). */
    Tcl_FSFreeInternalRepProc *freeInternalRepProc;
				/* Function to free internal fs rep. Must be

				 * implemented if internal representations
				 * need freeing, otherwise it can be NULL. */
    Tcl_FSInternalToNormalizedProc *internalToNormalizedProc;
				/* Function to convert internal representation
				 * to a normalized path. Only required if the
				 * fs creates pure path objects with no
				 * string/path representation. */
    Tcl_FSCreateInternalRepProc *createInternalRepProc;
				/* Function to create a filesystem-specific
				 * internal representation. May be NULL if
				 * paths have no internal representation, or
				 * if the Tcl_FSPathInFilesystemProc for this
				 * filesystem always immediately creates an
				 * internal representation for paths it
				 * accepts. */
    Tcl_FSNormalizePathProc *normalizePathProc;
				/* Function to normalize a path.  Should be
				 * implemented for all filesystems which can
				 * have multiple string representations for
				 * the same path object. */
    Tcl_FSFilesystemPathTypeProc *filesystemPathTypeProc;
				/* Function to determine the type of a path in
				 * this filesystem. May be NULL. */
    Tcl_FSFilesystemSeparatorProc *filesystemSeparatorProc;
				/* Function to return the separator
				 * character(s) for this filesystem. Must be
				 * implemented. */
    Tcl_FSStatProc *statProc;	/* Function to process a 'Tcl_FSStat()' call.
				 * Must be implemented for any reasonable
				 * filesystem. */
    Tcl_FSAccessProc *accessProc;
				/* Function to process a 'Tcl_FSAccess()'
				 * call. Must be implemented for any
				 * reasonable filesystem. */
    Tcl_FSOpenFileChannelProc *openFileChannelProc;
				/* Function to process a
				 * 'Tcl_FSOpenFileChannel()' call. Must be
				 * implemented for any reasonable
				 * filesystem. */
    Tcl_FSMatchInDirectoryProc *matchInDirectoryProc;
				/* Function to process a
				 * 'Tcl_FSMatchInDirectory()'.  If not

				 * implemented, then glob and recursive copy
				 * functionality will be lacking in the
				 * filesystem. */
    Tcl_FSUtimeProc *utimeProc;	/* Function to process a 'Tcl_FSUtime()' call.
				 * Required to allow setting (not reading) of
				 * times with 'file mtime', 'file atime' and
				 * the open-r/open-w/fcopy implementation of
				 * 'file copy'. */
    Tcl_FSLinkProc *linkProc;	/* Function to process a 'Tcl_FSLink()' call.
				 * Should be implemented only if the
				 * filesystem supports links (reading or
				 * creating). */
    Tcl_FSListVolumesProc *listVolumesProc;
				/* Function to list any filesystem volumes
				 * added by this filesystem. Should be
				 * implemented only if the filesystem adds
				 * volumes at the head of the filesystem. */
    Tcl_FSFileAttrStringsProc *fileAttrStringsProc;
				/* Function to list all attributes strings
				 * which are valid for this filesystem. If not
				 * implemented the filesystem will not support
				 * the 'file attributes' command. This allows
				 * arbitrary additional information to be
				 * attached to files in the filesystem. */
    Tcl_FSFileAttrsGetProc *fileAttrsGetProc;
				/* Function to process a
				 * 'Tcl_FSFileAttrsGet()' call, used by 'file
				 * attributes'. */
    Tcl_FSFileAttrsSetProc *fileAttrsSetProc;
				/* Function to process a
				 * 'Tcl_FSFileAttrsSet()' call, used by 'file
				 * attributes'.  */
    Tcl_FSCreateDirectoryProc *createDirectoryProc;
				/* Function to process a
				 * 'Tcl_FSCreateDirectory()' call. Should be
				 * implemented unless the FS is read-only. */
    Tcl_FSRemoveDirectoryProc *removeDirectoryProc;
				/* Function to process a
				 * 'Tcl_FSRemoveDirectory()' call. Should be
				 * implemented unless the FS is read-only. */
    Tcl_FSDeleteFileProc *deleteFileProc;
				/* Function to process a 'Tcl_FSDeleteFile()'
				 * call. Should be implemented unless the FS
				 * is read-only. */
    Tcl_FSCopyFileProc *copyFileProc;
				/* Function to process a 'Tcl_FSCopyFile()'
				 * call. If not implemented Tcl will fall back

				 * on open-r, open-w and fcopy as a copying
				 * mechanism, for copying actions initiated in
				 * Tcl (not C). */
    Tcl_FSRenameFileProc *renameFileProc;
				/* Function to process a 'Tcl_FSRenameFile()'

				 * call. If not implemented, Tcl will fall
				 * back on a copy and delete mechanism, for
				 * rename actions initiated in Tcl (not C). */
    Tcl_FSCopyDirectoryProc *copyDirectoryProc;
				/* Function to process a
				 * 'Tcl_FSCopyDirectory()' call. If not
				 * implemented, Tcl will fall back on a
				 * recursive create-dir, file copy mechanism,
				 * for copying actions initiated in Tcl (not
				 * C). */
    Tcl_FSLstatProc *lstatProc;	/* Function to process a 'Tcl_FSLstat()' call.
				 * If not implemented, Tcl will attempt to use
				 * the 'statProc' defined above instead. */
    Tcl_FSLoadFileProc *loadFileProc;
				/* Function to process a 'Tcl_FSLoadFile()'
				 * call. If not implemented, Tcl will fall
				 * back on a copy to native-temp followed by a
				 * Tcl_FSLoadFile on that temporary copy. */
    Tcl_FSGetCwdProc *getCwdProc;
				/* Function to process a 'Tcl_FSGetCwd()'
				 * call. Most filesystems need not implement
				 * this. It will usually only be called once,
				 * if 'getcwd' is called before 'chdir'. May
				 * be NULL. */
    Tcl_FSChdirProc *chdirProc;	/* Function to process a 'Tcl_FSChdir()' call.
				 * If filesystems do not implement this, it
				 * will be emulated by a series of directory
				 * access checks. Otherwise, virtual
				 * filesystems which do implement it need only
				 * respond with a positive return result if
				 * the dirName is a valid directory in their
				 * filesystem. They need not remember the
				 * result, since that will be automatically
				 * remembered for use by GetCwd. Real
				 * filesystems should carry out the correct
				 * action (i.e. call the correct system
				 * 'chdir' api). If not implemented, then 'cd'
				 * and 'pwd' will fail inside the
				 * filesystem. */




} Tcl_Filesystem;

/*
 * The following definitions are used as values for the 'linkAction' flag to
 * Tcl_FSLink, or the linkProc of any filesystem. Any combination of flags can
 * be given. For link creation, the linkProc should create a link which
 * matches any of the types given.







|














|



|
>
|

|
>
|
<

|
<
|
|

<
|
|
|
|
|
|

|
|
<
|

|
|

|
|
<
|
<
|

|
<
|

<
|
<
|

<
|
>
|
<
<
|
|
<
|
|
|
<
<
|

|
|
<
|

|
<
|
|
|
|

<
|
|

<
|
|

<
|
|

<
|
|

|
<
|

|
<
>
|
<
<

|
>
|
|
<

<
|
<
|
|
|
|
<
|

|
|
|
|

|
<
|
|
<
|
|
<
|
<
<
|
|
<
<
<
|
|
|
|
>
>
>
>







1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681

1682
1683

1684
1685
1686

1687
1688
1689
1690
1691
1692
1693
1694
1695

1696
1697
1698
1699
1700
1701
1702

1703

1704
1705
1706

1707
1708

1709

1710
1711

1712
1713
1714


1715
1716

1717
1718
1719


1720
1721
1722
1723

1724
1725
1726

1727
1728
1729
1730
1731

1732
1733
1734

1735
1736
1737

1738
1739
1740

1741
1742
1743
1744

1745
1746
1747

1748
1749


1750
1751
1752
1753
1754

1755

1756

1757
1758
1759
1760

1761
1762
1763
1764
1765
1766
1767
1768

1769
1770

1771
1772

1773


1774
1775



1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790

#define TCL_FILESYSTEM_VERSION_1	((Tcl_FSVersion) 0x1)

/*
 * struct Tcl_Filesystem:
 *
 * One such structure exists for each type (kind) of filesystem. It collects
 * together the functions that form the interface for a particulr the
 * filesystem. Tcl always accesses the filesystem through one of these
 * structures.
 *
 * Not all entries need be non-NULL; any which are NULL are simply ignored.
 * However, a complete filesystem should provide all of these functions. The
 * explanations in the structure show the importance of each function.
 */

typedef struct Tcl_Filesystem {
    const char *typeName;	/* The name of the filesystem. */
    int structureLength;	/* Length of this structure, so future binary
				 * compatibility can be assured. */
    Tcl_FSVersion version;	/* Version of the filesystem type. */
    Tcl_FSPathInFilesystemProc *pathInFilesystemProc;
				/* Determines whether the pathname is in this
				 * filesystem. This is the most important
				 * filesystem function. */
    Tcl_FSDupInternalRepProc *dupInternalRepProc;
				/* Duplicates the internal handle of the node.
				 * If it is NULL, the filesystem is less
				 * performant. */
    Tcl_FSFreeInternalRepProc *freeInternalRepProc;
				/* Frees the internal handle of the node.  NULL
				 * only if there is no need to free resources
				 * used for the internal handle. */

    Tcl_FSInternalToNormalizedProc *internalToNormalizedProc;
				/* Converts the internal handle to a normalized

				 * path.  NULL if the filesystem creates nodes
				 * having no pathname. */
    Tcl_FSCreateInternalRepProc *createInternalRepProc;

				/* Creates an internal handle for a pathname.
				 * May be NULL if pathnames have no internal
				 * handle or if pathInFilesystemProc always
				 * immediately creates an internal
				 * representation for pathnames in the
				 * filesystem. */
    Tcl_FSNormalizePathProc *normalizePathProc;
				/* Normalizes a path.  Should be implemented if
				 * the filesystems supports multiple paths to

				 * the same node. */
    Tcl_FSFilesystemPathTypeProc *filesystemPathTypeProc;
				/* Determines the type of a path in this
				 * filesystem. May be NULL. */
    Tcl_FSFilesystemSeparatorProc *filesystemSeparatorProc;
				/* Produces the separator character(s) for this
				 * filesystem. Must not be NULL. */

    Tcl_FSStatProc *statProc;	/* Called by 'Tcl_FSStat()'.  Provided by any

				 * reasonable filesystem. */
    Tcl_FSAccessProc *accessProc;
				/* Called by 'Tcl_FSAccess()'.  Implemented by

				 * any reasonable filesystem. */
    Tcl_FSOpenFileChannelProc *openFileChannelProc;

				/* Called by 'Tcl_FSOpenFileChannel()'.

				 * Provided by any reasonable filesystem. */
    Tcl_FSMatchInDirectoryProc *matchInDirectoryProc;

				/* Called by 'Tcl_FSMatchInDirectory()'.  NULL
				 * if the filesystem does not support glob or
				 * recursive copy. */


    Tcl_FSUtimeProc *utimeProc;	/* Called by 'Tcl_FSUtime()', by 'file
				 *  mtime' to set (not read) times, 'file

				 *  atime', and the open-r/open-w/fcopy variant
				 *  of 'file copy'. */
    Tcl_FSLinkProc *linkProc;	/* Called by 'Tcl_FSLink()'. NULL if reading or


				 *  creating links is not supported. */
    Tcl_FSListVolumesProc *listVolumesProc;
				/* Lists filesystem volumes added by this
				 * filesystem. NULL if the filesystem does not

				 * use volumes. */
    Tcl_FSFileAttrStringsProc *fileAttrStringsProc;
				/* List all valid attributes strings.  NULL if

				 * the filesystem does not support the 'file
				 * attributes' command.  Can be used to attach
				 * arbitrary additional data to files in a
				 * filesystem. */
    Tcl_FSFileAttrsGetProc *fileAttrsGetProc;

				/* Called by 'Tcl_FSFileAttrsGet()' and by 
				 * 'file attributes'. */
    Tcl_FSFileAttrsSetProc *fileAttrsSetProc;

				/* Called by 'Tcl_FSFileAttrsSet()' and by
				 * 'file attributes'.  */
    Tcl_FSCreateDirectoryProc *createDirectoryProc;

				/* Called by 'Tcl_FSCreateDirectory()'.  May be
				 * NULL if the filesystem is read-only. */
    Tcl_FSRemoveDirectoryProc *removeDirectoryProc;

				/* Called by 'Tcl_FSRemoveDirectory()'.  May be
				 * NULL if the filesystem is read-only. */
    Tcl_FSDeleteFileProc *deleteFileProc;
				/* Called by 'Tcl_FSDeleteFile()' May be NULL

				 * if the filesystem is is read-only. */
    Tcl_FSCopyFileProc *copyFileProc;
				/* Called by 'Tcl_FSCopyFile()'.  If NULL, for

				 * a copy operation at the script level (not
				 * C) Tcl uses open-r, open-w and fcopy. */


    Tcl_FSRenameFileProc *renameFileProc;
				/* Called by 'Tcl_FSRenameFile()'. If NULL, for
				 * a rename operation at the script level (not
				 * C) Tcl performs a copy operation followed
				 * by a delete operation. */

    Tcl_FSCopyDirectoryProc *copyDirectoryProc;

				/* Called by 'Tcl_FSCopyDirectory()'. If NULL,

				 * for a copy operation at the script level
				 * (not C) Tcl recursively creates directories
				 * and copies files. */
    Tcl_FSLstatProc *lstatProc;	/* Called by 'Tcl_FSLstat()'. If NULL, Tcl

				 * attempts to use 'statProc' instead. */
    Tcl_FSLoadFileProc *loadFileProc;
				/* Called by 'Tcl_FSLoadFile()'. If NULL, Tcl
				 * performs a copy to a temporary file in the
				 * native filesystem and then calls
				 * Tcl_FSLoadFile() on that temporary copy. */
    Tcl_FSGetCwdProc *getCwdProc;
				/* Called by 'Tcl_FSGetCwd()'.  Normally NULL.

				 * Usually only called once:  If 'getcwd' is
				 * called before 'chdir' is ever called. */

    Tcl_FSChdirProc *chdirProc;	/* Called by 'Tcl_FSChdir()'.  For a virtual
				 * filesystem, chdirProc just returns zero

				 * (success) if the pathname is a valid


				 * directory, and some other value otherwise.
				 * For A real filesystem, chdirProc performs



				 * the correct action, e.g.  calls the system
				 * 'chdir' function. If not implemented, then
				 * 'cd' and 'pwd' fail for a pathname in this
				 * filesystem. On success Tcl stores the
				 * pathname for use by GetCwd.  If NULL, Tcl
				 * performs records the pathname as the new
				 * current directory if it passes a series of
				 * directory access checks. */
} Tcl_Filesystem;

/*
 * The following definitions are used as values for the 'linkAction' flag to
 * Tcl_FSLink, or the linkProc of any filesystem. Any combination of flags can
 * be given. For link creation, the linkProc should create a link which
 * matches any of the types given.
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
 *				block in a (potentially multi-block) input
 *				stream. Tells the conversion routine to
 *				perform any finalization that needs to occur
 *				after the last byte is converted and then to
 *				reset to an initial state. If the source
 *				buffer contains the entire input stream to be
 *				converted, this flag should be set.
 * TCL_ENCODING_STOPONERROR -	If set, then the converter will return
 *				immediately upon encountering an invalid byte
 *				sequence or a source character that has no
 *				mapping in the target encoding. If clear, then
 *				the converter will skip the problem,
 *				substituting one or more "close" characters in
 *				the destination buffer and then continue to
 *				convert the source.
 * TCL_ENCODING_NO_TERMINATE - 	If set, Tcl_ExternalToUtf will not append a
 *				terminating NUL byte.  Knowing that it will
 *				not need space to do so, it will fill all
 *				dstLen bytes with encoded UTF-8 content, as
 *				other circumstances permit.  If clear, the
 *				default behavior is to reserve a byte in
 *				the dst space for NUL termination, and to
 *				append the NUL byte.
 * TCL_ENCODING_CHAR_LIMIT -	If set and dstCharsPtr is not NULL, then
 *				Tcl_ExternalToUtf takes the initial value
 *				of *dstCharsPtr is taken as a limit of the
 *				maximum number of chars to produce in the
 *				encoded UTF-8 content.  Otherwise, the
 *				number of chars produced is controlled only
 *				by other limiting factors.
 */

#define TCL_ENCODING_START		0x01
#define TCL_ENCODING_END		0x02
#define TCL_ENCODING_STOPONERROR	0x04
#define TCL_ENCODING_NO_TERMINATE	0x08
#define TCL_ENCODING_CHAR_LIMIT		0x10







|
|
|
|
|
|
|

|
|
|
|
|
<
|
|

|
|
|
|
|
|







2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056

2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
 *				block in a (potentially multi-block) input
 *				stream. Tells the conversion routine to
 *				perform any finalization that needs to occur
 *				after the last byte is converted and then to
 *				reset to an initial state. If the source
 *				buffer contains the entire input stream to be
 *				converted, this flag should be set.
 * TCL_ENCODING_STOPONERROR -	If set, the converter returns immediately upon
 *				encountering an invalid byte sequence or a
 *				source character that has no mapping in the
 *				target encoding. If clear, the converter
 *				substitues the problematic character(s) with
 *				one or more "close" characters in the
 *				destination buffer and then continues to
 *				convert the source.
 * TCL_ENCODING_NO_TERMINATE - 	If set, Tcl_ExternalToUtf does not append a
 *				terminating NUL byte.  Since it does not need
 *				an extra byte for a terminating NUL, it fills
 *				all dstLen bytes with encoded UTF-8 content if
 *				needed.  If clear, a byte is reserved in the

 *				dst space for NUL termination, and a
 *				terminating NUL is appended.
 * TCL_ENCODING_CHAR_LIMIT -	If set and dstCharsPtr is not NULL, then
 *				Tcl_ExternalToUtf takes the initial value of
 *				*dstCharsPtr as a limit of the maximum number
 *				of chars to produce in the encoded UTF-8
 *				content.  Otherwise, the number of chars
 *				produced is controlled only by other limiting
 *				factors.
 */

#define TCL_ENCODING_START		0x01
#define TCL_ENCODING_END		0x02
#define TCL_ENCODING_STOPONERROR	0x04
#define TCL_ENCODING_NO_TERMINATE	0x08
#define TCL_ENCODING_CHAR_LIMIT		0x10
Changes to generic/tclEncoding.c.
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
				 * points to an array of 256 shorts. If there
				 * is no corresponding character the encoding,
				 * the value in the matrix is 0x0000.
				 * malloc'd. */
} TableEncodingData;

/*
 * The following structures is the clientData for a dynamically-loaded,
 * escape-driven encoding that is itself comprised of other simpler encodings.
 * An example is "iso-2022-jp", which uses escape sequences to switch between
 * ascii, jis0208, jis0212, gb2312, and ksc5601. Note that "escape-driven"
 * does not necessarily mean that the ESCAPE character is the character used
 * for switching character sets.
 */








|







79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
				 * points to an array of 256 shorts. If there
				 * is no corresponding character the encoding,
				 * the value in the matrix is 0x0000.
				 * malloc'd. */
} TableEncodingData;

/*
 * Each of the following structures is the clientData for a dynamically-loaded
 * escape-driven encoding that is itself comprised of other simpler encodings.
 * An example is "iso-2022-jp", which uses escape sequences to switch between
 * ascii, jis0208, jis0212, gb2312, and ksc5601. Note that "escape-driven"
 * does not necessarily mean that the ESCAPE character is the character used
 * for switching character sets.
 */

113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
    char prefixBytes[256];	/* If a byte in the input stream is the first
				 * character of one of the escape sequences in
				 * the following array, the corresponding
				 * entry in this array is 1, otherwise it is
				 * 0. */
    int numSubTables;		/* Length of following array. */
    EscapeSubTable subTables[1];/* Information about each EscapeSubTable used
				 * by this encoding type. The actual size will
				 * be as large as necessary to hold all
				 * EscapeSubTables. */
} EscapeEncodingData;

/*
 * Constants used when loading an encoding file to identify the type of the
 * file.
 */







|
|







113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
    char prefixBytes[256];	/* If a byte in the input stream is the first
				 * character of one of the escape sequences in
				 * the following array, the corresponding
				 * entry in this array is 1, otherwise it is
				 * 0. */
    int numSubTables;		/* Length of following array. */
    EscapeSubTable subTables[1];/* Information about each EscapeSubTable used
				 * by this encoding type. The actual size is
				 * as large as necessary to hold all
				 * EscapeSubTables. */
} EscapeEncodingData;

/*
 * Constants used when loading an encoding file to identify the type of the
 * file.
 */
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
    0, 0, NULL, NULL, NULL, NULL, NULL
};

/*
 * A list of directories making up the "library path". Historically this
 * search path has served many uses, but the only one remaining is a base for
 * the encodingSearchPath above. If the application does not explicitly set
 * the encodingSearchPath, then it will be initialized by appending /encoding
 * to each directory in this "libraryPath".
 */

static ProcessGlobalValue libraryPath = {
    0, 0, NULL, NULL, TclpInitLibraryPath, NULL, NULL
};

static int encodingsInitialized = 0;

/*
 * Hash table that keeps track of all loaded Encodings. Keys are the string
 * names that represent the encoding, values are (Encoding *).
 */

static Tcl_HashTable encodingTable;
TCL_DECLARE_MUTEX(encodingMutex)

/*
 * The following are used to hold the default and current system encodings.
 * If NULL is passed to one of the conversion routines, the current setting of
 * the system encoding will be used to perform the conversion.
 */

static Tcl_Encoding defaultEncoding = NULL;
static Tcl_Encoding systemEncoding = NULL;
Tcl_Encoding tclIdentityEncoding = NULL;

/*







|




















|







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
    0, 0, NULL, NULL, NULL, NULL, NULL
};

/*
 * A list of directories making up the "library path". Historically this
 * search path has served many uses, but the only one remaining is a base for
 * the encodingSearchPath above. If the application does not explicitly set
 * the encodingSearchPath, then it is initialized by appending /encoding
 * to each directory in this "libraryPath".
 */

static ProcessGlobalValue libraryPath = {
    0, 0, NULL, NULL, TclpInitLibraryPath, NULL, NULL
};

static int encodingsInitialized = 0;

/*
 * Hash table that keeps track of all loaded Encodings. Keys are the string
 * names that represent the encoding, values are (Encoding *).
 */

static Tcl_HashTable encodingTable;
TCL_DECLARE_MUTEX(encodingMutex)

/*
 * The following are used to hold the default and current system encodings.
 * If NULL is passed to one of the conversion routines, the current setting of
 * the system encoding is used to perform the conversion.
 */

static Tcl_Encoding defaultEncoding = NULL;
static Tcl_Encoding systemEncoding = NULL;
Tcl_Encoding tclIdentityEncoding = NULL;

/*
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
 *----------------------------------------------------------------------
 *
 * TclSetLibraryPath --
 *
 *	Keeps the per-thread copy of the library path current with changes to
 *	the global copy.
 *
 *	NOTE: this routine returns void, so there's no way to report the error
 *	that searchPath is not a valid list. In that case, this routine will
 *	silently do nothing.
 *
 *----------------------------------------------------------------------
 */

void
TclSetLibraryPath(
    Tcl_Obj *path)







<
|
|







447
448
449
450
451
452
453

454
455
456
457
458
459
460
461
462
 *----------------------------------------------------------------------
 *
 * TclSetLibraryPath --
 *
 *	Keeps the per-thread copy of the library path current with changes to
 *	the global copy.
 *

 *	Since the result of this routine is void, if searchPath is not a valid
 *	list this routine silently does nothing.
 *
 *----------------------------------------------------------------------
 */

void
TclSetLibraryPath(
    Tcl_Obj *path)
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
}

/*
 *---------------------------------------------------------------------------
 *
 * FillEncodingFileMap --
 *
 *	Called to bring the encoding file map in sync with the current value
 *	of the encoding search path.
 *
 *	Scan the directories on the encoding search path, find the *.enc
 *	files, and store the found pathnames in a map associated with the
 *	encoding name.
 *
 *	In particular, if $dir is on the encoding search path, and the file
 *	$dir/foo.enc is found, then store a "foo" -> $dir entry in the map.
 *	Later, any need for the "foo" encoding will quickly * be able to
 *	construct the $dir/foo.enc pathname for reading the encoding data.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Entries are added to the encoding file map.
 *







|


|
|
<

|
|
|
|







470
471
472
473
474
475
476
477
478
479
480
481

482
483
484
485
486
487
488
489
490
491
492
493
}

/*
 *---------------------------------------------------------------------------
 *
 * FillEncodingFileMap --
 *
 *	Called to update the encoding file map with the current value
 *	of the encoding search path.
 *
 *	Finds *.end files in the directories on the encoding search path and
 *	stores the found pathnames in a map associated with the encoding name.

 *
 *	If $dir is on the encoding search path and the file $dir/foo.enc is
 *	found, stores a "foo" -> $dir entry in the map.  if the "foo" encoding
 *	is needed later, the $dir/foo.enc name can be quickly constructed in
 *	order to read the encoding data.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Entries are added to the encoding file map.
 *
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596

    isLe.s = 1;
    Tcl_MutexLock(&encodingMutex);
    Tcl_InitHashTable(&encodingTable, TCL_STRING_KEYS);
    Tcl_MutexUnlock(&encodingMutex);

    /*
     * Create a few initial encodings. Note that the UTF-8 to UTF-8
     * translation is not a no-op, because it will turn a stream of improperly
     * formed UTF-8 into a properly formed stream.
     */

    type.encodingName	= NULL;
    type.toUtfProc	= BinaryProc;
    type.fromUtfProc	= BinaryProc;
    type.freeProc	= NULL;
    type.nullSize	= 1;







|
|
|







578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594

    isLe.s = 1;
    Tcl_MutexLock(&encodingMutex);
    Tcl_InitHashTable(&encodingTable, TCL_STRING_KEYS);
    Tcl_MutexUnlock(&encodingMutex);

    /*
     * Create a few initial encodings.  UTF-8 to UTF-8 translation is not a
     * no-op because it turns a stream of improperly formed UTF-8 into a
     * properly formed stream.
     */

    type.encodingName	= NULL;
    type.toUtfProc	= BinaryProc;
    type.fromUtfProc	= BinaryProc;
    type.freeProc	= NULL;
    type.nullSize	= 1;
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
 * Results:
 *	Returns a token that represents the encoding. If the name didn't refer
 *	to any known or loadable encoding, NULL is returned. If NULL was
 *	returned, an error message is left in interp's result object, unless
 *	interp was NULL.
 *
 * Side effects:
 *	The new encoding type is entered into a table visible to all
 *	interpreters, keyed off the encoding's name. For each call to this
 *	function, there should eventually be a call to Tcl_FreeEncoding, so
 *	that the database can be cleaned up when encodings aren't needed
 *	anymore.
 *
 *-------------------------------------------------------------------------
 */

Tcl_Encoding
Tcl_GetEncoding(
    Tcl_Interp *interp,		/* Interp for error reporting, if not NULL. */







<
<
|
<
<







800
801
802
803
804
805
806


807


808
809
810
811
812
813
814
 * Results:
 *	Returns a token that represents the encoding. If the name didn't refer
 *	to any known or loadable encoding, NULL is returned. If NULL was
 *	returned, an error message is left in interp's result object, unless
 *	interp was NULL.
 *
 * Side effects:


 *	LoadEncodingFile is called if necessary.


 *
 *-------------------------------------------------------------------------
 */

Tcl_Encoding
Tcl_GetEncoding(
    Tcl_Interp *interp,		/* Interp for error reporting, if not NULL. */
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
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FreeEncoding --
 *
 *	This function is called to release an encoding allocated by
 *	Tcl_CreateEncoding() or Tcl_GetEncoding().
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The reference count associated with the encoding is decremented and
 *	the encoding may be deleted if nothing is using it anymore.
 *
 *---------------------------------------------------------------------------
 */

void
Tcl_FreeEncoding(
    Tcl_Encoding encoding)
{
    Tcl_MutexLock(&encodingMutex);
    FreeEncoding(encoding);
    Tcl_MutexUnlock(&encodingMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * FreeEncoding --
 *
 *	This function is called to release an encoding by functions that
 *	already have the encodingMutex.
 *
 * Results:
 *	None.
 *
 * Side effects:

 *	The reference count associated with the encoding is decremented and
 *	the encoding may be deleted if nothing is using it anymore.
 *
 *----------------------------------------------------------------------
 */

static void







|
|






|


















|
|





>







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
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FreeEncoding --
 *
 *	Releases an encoding allocated by Tcl_CreateEncoding() or
 *	Tcl_GetEncoding().
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The reference count associated with the encoding is decremented and
 *	the encoding is deleted if nothing is using it anymore.
 *
 *---------------------------------------------------------------------------
 */

void
Tcl_FreeEncoding(
    Tcl_Encoding encoding)
{
    Tcl_MutexLock(&encodingMutex);
    FreeEncoding(encoding);
    Tcl_MutexUnlock(&encodingMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * FreeEncoding --
 *
 *	Decrements the reference count of an encoding.  The caller must hold
 *	encodingMutes.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Releases the resource for an encoding if it is now unused.
 *	The reference count associated with the encoding is decremented and
 *	the encoding may be deleted if nothing is using it anymore.
 *
 *----------------------------------------------------------------------
 */

static void
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_CreateEncoding --
 *
 *	This function is called to define a new encoding and the functions
 *	that are used to convert between the specified encoding and Unicode.
 *
 * Results:
 *	Returns a token that represents the encoding. If an encoding with the
 *	same name already existed, the old encoding token remains valid and
 *	continues to behave as it used to, and will eventually be garbage
 *	collected when the last reference to it goes away. Any subsequent
 *	calls to Tcl_GetEncoding with the specified name will retrieve the
 *	most recent encoding token.
 *
 * Side effects:
 *	The new encoding type is entered into a table visible to all
 *	interpreters, keyed off the encoding's name. For each call to this
 *	function, there should eventually be a call to Tcl_FreeEncoding, so
 *	that the database can be cleaned up when encodings aren't needed
 *	anymore.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Encoding
Tcl_CreateEncoding(
    const Tcl_EncodingType *typePtr)







|
|




|
|
|
|


|
|
|
|
<







1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082

1083
1084
1085
1086
1087
1088
1089
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_CreateEncoding --
 *
 *	Defines a new encoding, along with the functions that are used to
 *	convert to and from Unicode.
 *
 * Results:
 *	Returns a token that represents the encoding. If an encoding with the
 *	same name already existed, the old encoding token remains valid and
 *	continues to behave as it used to, and is eventually garbage collected
 *	when the last reference to it goes away. Any subsequent calls to
 *	Tcl_GetEncoding with the specified name retrieve the most recent
 *	encoding token.
 *
 * Side effects:
 *	A new record having the name of the encoding is entered into a table of
 *	encodings visible to all interpreters.  For each call to this function,
 *	there should eventually be a call to Tcl_FreeEncoding, which cleans
 *	deletes the record in the table when an encoding is no longer needed.

 *
 *---------------------------------------------------------------------------
 */

Tcl_Encoding
Tcl_CreateEncoding(
    const Tcl_EncodingType *typePtr)
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
}

/*
 *-------------------------------------------------------------------------
 *
 * Tcl_UtfToExternalDString --
 *
 *	Convert a source buffer from UTF-8 into the specified encoding. If any
 *	of the bytes in the source buffer are invalid or cannot be represented
 *	in the target encoding, a default fallback character will be
 *	substituted.
 *
 * Results:
 *	The converted bytes are stored in the DString, which is then NULL
 *	terminated in an encoding-specific manner. The return value is a
 *	pointer to the value stored in the DString.
 *
 * Side effects:







|

|
<







1322
1323
1324
1325
1326
1327
1328
1329
1330
1331

1332
1333
1334
1335
1336
1337
1338
}

/*
 *-------------------------------------------------------------------------
 *
 * Tcl_UtfToExternalDString --
 *
 *	Convert a source buffer from UTF-8 to the specified encoding. If any
 *	of the bytes in the source buffer are invalid or cannot be represented
 *	in the target encoding, a default fallback character is substituted.

 *
 * Results:
 *	The converted bytes are stored in the DString, which is then NULL
 *	terminated in an encoding-specific manner. The return value is a
 *	pointer to the value stored in the DString.
 *
 * Side effects:
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655

1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
 *
 * LoadEncodingFile --
 *
 *	Read a file that describes an encoding and create a new Encoding from
 *	the data.
 *
 * Results:
 *	The return value is the newly loaded Encoding, or NULL if the file
 *	didn't exist of was in the incorrect format. If NULL was returned, an
 *	error message is left in interp's result object, unless interp was
 *	NULL.
 *
 * Side effects:
 *	File read from disk.

 *
 *---------------------------------------------------------------------------
 */

static Tcl_Encoding
LoadEncodingFile(
    Tcl_Interp *interp,		/* Interp for error reporting, if not NULL. */
    const char *name)		/* The name of the encoding file on disk and
				 * also the name for new encoding. */
{
    Tcl_Channel chan = NULL;
    Tcl_Encoding encoding = NULL;
    int ch;

    chan = OpenEncodingFileChannel(interp, name);
    if (chan == NULL) {







|
|
|
<


|
>







|
|







1635
1636
1637
1638
1639
1640
1641
1642
1643
1644

1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
 *
 * LoadEncodingFile --
 *
 *	Read a file that describes an encoding and create a new Encoding from
 *	the data.
 *
 * Results:
 *	The return value is the newly loaded Tcl_Encoding or NULL if the file
 *	didn't exist or could not be processed. If NULL is returned and interp
 *	is not NULL, an error message is left in interp's result object.

 *
 * Side effects:
 *	A corresponding encoding file might be read from persistent storage, in
 *	which case LoadTableEncoding is called.
 *
 *---------------------------------------------------------------------------
 */

static Tcl_Encoding
LoadEncodingFile(
    Tcl_Interp *interp,		/* Interp for error reporting, if not NULL. */
    const char *name)		/* The name of both the encoding file
				 * and the new encoding. */
{
    Tcl_Channel chan = NULL;
    Tcl_Encoding encoding = NULL;
    int ch;

    chan = OpenEncodingFileChannel(interp, name);
    if (chan == NULL) {
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
}

/*
 *-------------------------------------------------------------------------
 *
 * LoadTableEncoding --
 *
 *	Helper function for LoadEncodingTable(). Loads a table to that
 *	converts between Unicode and some other encoding and creates an
 *	encoding (using a TableEncoding structure) from that information.
 *
 *	File contains binary data, but begins with a marker to indicate
 *	byte-ordering, so that same binary file can be read on either endian
 *	platforms.
 *
 * Results:
 *	The return value is the new encoding, or NULL if the encoding could
 *	not be created (because the file contained invalid data).
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static Tcl_Encoding
LoadTableEncoding(
    const char *name,		/* Name for new encoding. */
    int type,			/* Type of encoding (ENCODING_?????). */
    Tcl_Channel chan)		/* File containing new encoding. */
{
    Tcl_DString lineString;
    Tcl_Obj *objPtr;
    char *line;
    int i, hi, lo, numPages, symbol, fallback, len;







|
|
|

|
|
|


|
|


|






|







1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
}

/*
 *-------------------------------------------------------------------------
 *
 * LoadTableEncoding --
 *
 *	Helper function for LoadEncodingFile().  Creates a Tcl_EncodingType
 *	structure along with its corresponding TableEncodingData structure, and
 *	passes it to Tcl_Createncoding.
 *
 *	The file contains binary data but begins with a marker to indicate
 *	byte-ordering so a single binary file can be read on big or
 *	little-endian systems.
 *
 * Results:
 *	Returns the new Tcl_Encoding,  or NULL if it could could
 *	not be created because the file contained invalid data.
 *
 * Side effects:
 *	See Tcl_CreateEncoding(). 
 *
 *-------------------------------------------------------------------------
 */

static Tcl_Encoding
LoadTableEncoding(
    const char *name,		/* Name of the new encoding. */
    int type,			/* Type of encoding (ENCODING_?????). */
    Tcl_Channel chan)		/* File containing new encoding. */
{
    Tcl_DString lineString;
    Tcl_Obj *objPtr;
    char *line;
    int i, hi, lo, numPages, symbol, fallback, len;
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
	    if (dataPtr->toUnicode[hi] != NULL) {
		dataPtr->prefixBytes[hi] = 1;
	    }
	}
    }

    /*
     * Invert toUnicode array to produce the fromUnicode array. Performs a
     * single malloc to get the memory for the array and all the pages needed
     * by the array. While reading in the toUnicode array, we remembered what
     * pages that would be needed for the fromUnicode array.
     */

    if (symbol) {
	used[0] = 1;
    }
    numPages = 0;
    for (hi = 0; hi < 256; hi++) {







|

|
|







1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
	    if (dataPtr->toUnicode[hi] != NULL) {
		dataPtr->prefixBytes[hi] = 1;
	    }
	}
    }

    /*
     * Invert the toUnicode array to produce the fromUnicode array. Performs a
     * single malloc to get the memory for the array and all the pages needed
     * by the array. While reading in the toUnicode array remember what
     * pages are needed for the fromUnicode array.
     */

    if (symbol) {
	used[0] = 1;
    }
    numPages = 0;
    for (hi = 0; hi < 256; hi++) {
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
		page[ch & 0xff] = (unsigned short) ((hi << 8) + lo);
	    }
	}
    }
    if (type == ENCODING_MULTIBYTE) {
	/*
	 * If multibyte encodings don't have a backslash character, define
	 * one. Otherwise, on Windows, native file names won't work because
	 * the backslash in the file name will map to the unknown character
	 * (question mark) when converting from UTF-8 to external encoding.
	 */

	if (dataPtr->fromUnicode[0] != NULL) {
	    if (dataPtr->fromUnicode[0]['\\'] == '\0') {
		dataPtr->fromUnicode[0]['\\'] = '\\';
	    }
	}
    }
    if (symbol) {
	/*
	 * Make a special symbol encoding that not only maps the symbol
	 * characters from their Unicode code points down into page 0, but
	 * also ensure that the characters on page 0 map to themselves. This
	 * is so that a symbol font can be used to display a simple string
	 * like "abcd" and have alpha, beta, chi, delta show up, rather than
	 * have "unknown" chars show up because strictly speaking the symbol
	 * font doesn't have glyphs for those low ASCII chars.
	 */

	page = dataPtr->fromUnicode[0];
	if (page == NULL) {
	    page = pageMemPtr;
	    dataPtr->fromUnicode[0] = page;
	}







|
|











|
|
|
|
|
|
|







1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
		page[ch & 0xff] = (unsigned short) ((hi << 8) + lo);
	    }
	}
    }
    if (type == ENCODING_MULTIBYTE) {
	/*
	 * If multibyte encodings don't have a backslash character, define
	 * one. Otherwise, on Windows, native file names don't work because
	 * the backslash in the file name maps to the unknown character
	 * (question mark) when converting from UTF-8 to external encoding.
	 */

	if (dataPtr->fromUnicode[0] != NULL) {
	    if (dataPtr->fromUnicode[0]['\\'] == '\0') {
		dataPtr->fromUnicode[0]['\\'] = '\\';
	    }
	}
    }
    if (symbol) {
	/*
	 * Make a special symbol encoding that maps each symbol character from
	 * its Unicode code point down into page 0, and also ensure that each
	 * characters on page 0 maps to itself so that a symbol font can be
	 * used to display a simple string like "abcd" and have alpha, beta,
	 * chi, delta show up, rather than have "unknown" chars show up because
	 * strictly speaking the symbol font doesn't have glyphs for those low
	 * ASCII chars.
	 */

	page = dataPtr->fromUnicode[0];
	if (page == NULL) {
	    page = pageMemPtr;
	    dataPtr->fromUnicode[0] = page;
	}
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970

    line = Tcl_DStringValue(&lineString);
    if (line[0] != 'R') {
	goto doneParse;
    }

    /*
     * Read lines from the encoding until EOF.
     */

    for (TclDStringClear(&lineString);
	    (len = Tcl_Gets(chan, &lineString)) >= 0;
	    TclDStringClear(&lineString)) {
	const unsigned char *p;
	int to, from;







|







1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963

    line = Tcl_DStringValue(&lineString);
    if (line[0] != 'R') {
	goto doneParse;
    }

    /*
     * Read lines until EOF.
     */

    for (TclDStringClear(&lineString);
	    (len = Tcl_Gets(chan, &lineString)) >= 0;
	    TclDStringClear(&lineString)) {
	const unsigned char *p;
	int to, from;
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static Tcl_Encoding
LoadEscapeEncoding(
    const char *name,		/* Name for new encoding. */
    Tcl_Channel chan)		/* File containing new encoding. */
{
    int i;
    unsigned size;
    Tcl_DString escapeData;
    char init[16], final[16];
    EscapeEncodingData *dataPtr;







|







2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static Tcl_Encoding
LoadEscapeEncoding(
    const char *name,		/* Name of the new encoding. */
    Tcl_Channel chan)		/* File containing new encoding. */
{
    int i;
    unsigned size;
    Tcl_DString escapeData;
    char init[16], final[16];
    EscapeEncodingData *dataPtr;
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
}

/*
 *---------------------------------------------------------------------------
 *
 * EscapeFreeProc --
 *
 *	This function is invoked when an EscapeEncodingData encoding is
 *	deleted. It deletes the memory used by the encoding.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory freed.
 *
 *---------------------------------------------------------------------------
 */

static void
EscapeFreeProc(
    ClientData clientData)	/* EscapeEncodingData that specifies







<
|





|







3650
3651
3652
3653
3654
3655
3656

3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
}

/*
 *---------------------------------------------------------------------------
 *
 * EscapeFreeProc --
 *

 *	Frees resources used by the encoding.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory is freed.
 *
 *---------------------------------------------------------------------------
 */

static void
EscapeFreeProc(
    ClientData clientData)	/* EscapeEncodingData that specifies
Changes to generic/tclFileName.c.
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
}

/*
 *----------------------------------------------------------------------
 *
 * TclGlob --
 *
 *	This procedure prepares arguments for the DoGlob call. It sets the
 *	separator string based on the platform, performs * tilde substitution,
 *	and calls DoGlob.
 *
 *	The interpreter's result, on entry to this function, must be a valid
 *	Tcl list (e.g. it could be empty), since we will lappend any new
 *	results to that list. If it is not a valid list, this function will
 *	fail to do anything very meaningful.
 *
 *	Note that if globFlags contains 'TCL_GLOBMODE_TAILS' then pathPrefix







<
|
|







1676
1677
1678
1679
1680
1681
1682

1683
1684
1685
1686
1687
1688
1689
1690
1691
}

/*
 *----------------------------------------------------------------------
 *
 * TclGlob --
 *

 *	Sets the separator string based on the platform, performs tilde
 *	substitution, and calls DoGlob.
 *
 *	The interpreter's result, on entry to this function, must be a valid
 *	Tcl list (e.g. it could be empty), since we will lappend any new
 *	results to that list. If it is not a valid list, this function will
 *	fail to do anything very meaningful.
 *
 *	Note that if globFlags contains 'TCL_GLOBMODE_TAILS' then pathPrefix
Changes to generic/tclPathObj.c.
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
    UpdateStringOfFsPath,		/* updateStringProc */
    SetFsPathFromAny			/* setFromAnyProc */
};

/*
 * struct FsPath --
 *
 * Internal representation of a Tcl_Obj of "path" type. This can be used to
 * represent relative or absolute paths, and has certain optimisations when
 * used to represent paths which are already normalized and absolute.
 *
 * There are two cases, with the first being the most common:
 *
 * (i) flags == 0, => Ordinary path.
 *
 * translatedPathPtr contains the translated path. If it is NULL then the path
 * is pure normalized. cwdPtr is null for an absolute path, and non-null for a
 * relative path (unless the cwd has never been set, in which case the cwdPtr
 * may also be null for a relative path).
 *
 * (ii) flags != 0, => Special path, see TclNewFSPathObj
 *
 * Now, this is a path like 'file join $dir $tail' where, cwdPtr is the $dir
 * and normPathPtr is the $tail.
 *
 */

typedef struct FsPath {
    Tcl_Obj *translatedPathPtr; /* Name without any ~user sequences. If this
				 * is NULL, then this is a pure normalized,
				 * absolute path object, in which the parent
				 * Tcl_Obj's string rep is already both
				 * translated and normalized. */
    Tcl_Obj *normPathPtr;	/* Normalized absolute path, without ., .. or

				 * ~user sequences. */


    Tcl_Obj *cwdPtr;		/* If null, path is absolute, else this points
				 * to the cwd object used for this path. We
				 * have a refCount on the object. */
    int flags;			/* Flags to describe interpretation - see
				 * below. */
    ClientData nativePathPtr;	/* Native representation of this path, which
				 * is filesystem dependent. */
    int filesystemEpoch;	/* Used to ensure the path representation was
				 * generated during the correct filesystem
				 * epoch. The epoch changes when







|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<



|
|
|
<
|
|
>
|
>
>
|
<
|







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
    UpdateStringOfFsPath,		/* updateStringProc */
    SetFsPathFromAny			/* setFromAnyProc */
};

/*
 * struct FsPath --
 *
 * Internal representation of a Tcl_Obj of fsPathType 

















 */

typedef struct FsPath {
    Tcl_Obj *translatedPathPtr; /*  If the path has been normalized (flags ==
				 *  0), this is NULL.  Otherwise it is a path
				 *  in which any ~user sequences have been

				 *  translated away. */
    Tcl_Obj *normPathPtr;	/*  If the path has been normalized (flags ==
				 *  0), this is an absolute path without ., ..
				 *  or ~user components.  Otherwise it is a
				 *  path, possibly absolute, to normalize
				 *  relative to cwdPtr. */
    Tcl_Obj *cwdPtr;		/*  If NULL, either translatedPtr exists or

				 *  normPathPtr exists and is absolute. */
    int flags;			/* Flags to describe interpretation - see
				 * below. */
    ClientData nativePathPtr;	/* Native representation of this path, which
				 * is filesystem dependent. */
    int filesystemEpoch;	/* Used to ensure the path representation was
				 * generated during the correct filesystem
				 * epoch. The epoch changes when
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
 *
 *	The behaviour of this function if passed a non-absolute path is NOT
 *	defined.
 *
 *	pathPtr may have a refCount of zero, or may be a shared object.
 *
 * Results:
 *	The result is returned in a Tcl_Obj with a refCount of 1, which is
 *	therefore owned by the caller. It must be freed (with

 *	Tcl_DecrRefCount) by the caller when no longer needed.
 *
 * Side effects:
 *	None (beyond the memory allocation for the result).
 *
 * Special note:
 *	This code was originally based on code from Matt Newman and
 *	Jean-Claude Wippler, but has since been totally rewritten by Vince
 *	Darley to deal with symbolic links.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
TclFSNormalizeAbsolutePath(
    Tcl_Interp *interp,		/* Interpreter to use */







|
|
>
|





|
<
|







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
 *
 *	The behaviour of this function if passed a non-absolute path is NOT
 *	defined.
 *
 *	pathPtr may have a refCount of zero, or may be a shared object.
 *
 * Results:
 *	The result is returned in a Tcl_Obj with a refCount already
 *	incremented, which gives the caller ownership of it.  The caller must
 *	arrange for Tcl_DecRefCount to be called when the object is no-longer
 *	needed.
 *
 * Side effects:
 *	None (beyond the memory allocation for the result).
 *
 * Special note:
 *	Originally based on code from Matt Newman and Jean-Claude Wippler. 

 *	Totally rewritten later by Vince Darley to handle symbolic links.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
TclFSNormalizeAbsolutePath(
    Tcl_Interp *interp,		/* Interpreter to use */
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722

		Tcl_IncrRefCount(root);
		return root;
	    }
	}

	/*
	 * The behaviour we want here is slightly different to the standard
	 * Tcl_FSSplitPath in the handling of home directories;
	 * Tcl_FSSplitPath preserves the "~" while this code computes the
	 * actual full path name, if we had just a single component.
	 */

	splitPtr = Tcl_FSSplitPath(pathPtr, &splitElements);
	Tcl_IncrRefCount(splitPtr);
	if (splitElements == 1  &&  TclGetString(pathPtr)[0] == '~') {
	    Tcl_Obj *norm;







<

|







690
691
692
693
694
695
696

697
698
699
700
701
702
703
704
705

		Tcl_IncrRefCount(root);
		return root;
	    }
	}

	/*

	 * Tcl_FSSplitPath in the handling of home directories;
	 * Tcl_FSSplitPath preserves the "~",  but this code computes the
	 * actual full path name, if we had just a single component.
	 */

	splitPtr = Tcl_FSSplitPath(pathPtr, &splitElements);
	Tcl_IncrRefCount(splitPtr);
	if (splitElements == 1  &&  TclGetString(pathPtr)[0] == '~') {
	    Tcl_Obj *norm;
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
	 * we are joining a single relative path onto an object that is
	 * already of path type. The 'TclNewFSPathObj' call below creates an
	 * object which can be normalized more efficiently. Currently we only
	 * use the special case when we have exactly two elements, but we
	 * could expand that in the future.
	 *
	 * Bugfix [a47641a0]. TclNewFSPathObj requires first argument
	 * to be an absolute path. Added a check for that elt is absolute.
	 */

	if ((eltIr)
		&& !((elt->bytes != NULL) && (elt->bytes[0] == '\0'))
		&& TclGetPathType(elt, NULL, NULL, NULL) == TCL_PATH_ABSOLUTE) {
	    Tcl_Obj *tailObj = objv[1];
	    Tcl_PathType type;







|







850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
	 * we are joining a single relative path onto an object that is
	 * already of path type. The 'TclNewFSPathObj' call below creates an
	 * object which can be normalized more efficiently. Currently we only
	 * use the special case when we have exactly two elements, but we
	 * could expand that in the future.
	 *
	 * Bugfix [a47641a0]. TclNewFSPathObj requires first argument
	 * to be an absolute path. Added a check to ensure that elt is absolute.
	 */

	if ((eltIr)
		&& !((elt->bytes != NULL) && (elt->bytes[0] == '\0'))
		&& TclGetPathType(elt, NULL, NULL, NULL) == TCL_PATH_ABSOLUTE) {
	    Tcl_Obj *tailObj = objv[1];
	    Tcl_PathType type;
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSNewNativePath --
 *
 *	This function performs the something like the reverse of the usual
 *	obj->path->nativerep conversions. If some code retrieves a path in
 *	native form (from, e.g. readlink or a native dialog), and that path is
 *	to be used at the Tcl level, then calling this function is an
 *	efficient way of creating the appropriate path object type.
 *
 *	Any memory which is allocated for 'clientData' should be retained
 *	until clientData is passed to the filesystem's freeInternalRepProc







|







1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSNewNativePath --
 *
 *	Performs the something like the reverse of the usual
 *	obj->path->nativerep conversions. If some code retrieves a path in
 *	native form (from, e.g. readlink or a native dialog), and that path is
 *	to be used at the Tcl level, then calling this function is an
 *	efficient way of creating the appropriate path object type.
 *
 *	Any memory which is allocated for 'clientData' should be retained
 *	until clientData is passed to the filesystem's freeInternalRepProc
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583


1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601





1602
1603
1604
1605
1606
1607
1608
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSGetTranslatedPath --
 *
 *	This function attempts to extract the translated path from the given
 *	Tcl_Obj. If the translation succeeds (i.e. the object is a valid
 *	path), then it is returned. Otherwise NULL will be returned, and an
 *	error message may be left in the interpreter (if it is non-NULL)
 *
 * Results:
 *	NULL or a valid Tcl_Obj pointer.
 *
 * Side effects:
 *	Only those of 'Tcl_FSConvertToPathType'


 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_FSGetTranslatedPath(
    Tcl_Interp *interp,
    Tcl_Obj *pathPtr)
{
    Tcl_Obj *retObj = NULL;
    FsPath *srcFsPathPtr;

    if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) {
	return NULL;
    }
    srcFsPathPtr = PATHOBJ(pathPtr);
    if (srcFsPathPtr->translatedPathPtr == NULL) {
	if (PATHFLAGS(pathPtr) != 0) {





	    /*
	     * We lack a translated path result, but we have a directory
	     * (cwdPtr) and a tail (normPathPtr), and if we join the
	     * translated version of cwdPtr to normPathPtr, we'll get the
	     * translated result we need, and can store it for future use.
	     */








|

|
|


|


|
>
>

















|
>
>
>
>
>







1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSGetTranslatedPath --
 *
 *	Attempts to extract the translated path from the given
 *	Tcl_Obj. If the translation succeeds (i.e. the object is a valid
 *	path), then it is returned. Otherwise NULL is returned and an
 *	error message may be left in the interpreter if it is not NULL.
 *
 * Results:
 *	A Tcl_Obj pointer or NULL.
 *
 * Side effects:
 *	pathPtr is converted to fsPathType if necessary.
 *
 *	FsPath members are modified as needed.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_FSGetTranslatedPath(
    Tcl_Interp *interp,
    Tcl_Obj *pathPtr)
{
    Tcl_Obj *retObj = NULL;
    FsPath *srcFsPathPtr;

    if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) {
	return NULL;
    }
    srcFsPathPtr = PATHOBJ(pathPtr);
    if (srcFsPathPtr->translatedPathPtr == NULL) {
	if (PATHFLAGS(pathPtr) == 0) {
	    /*
	     * Path is already normalized
	     */
	    retObj = srcFsPathPtr->normPathPtr;
	} else {
	    /*
	     * We lack a translated path result, but we have a directory
	     * (cwdPtr) and a tail (normPathPtr), and if we join the
	     * translated version of cwdPtr to normPathPtr, we'll get the
	     * translated result we need, and can store it for future use.
	     */

1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
	    if (translatedCwdIrPtr) {
		srcFsPathPtr->filesystemEpoch
			= PATHOBJ(translatedCwdPtr)->filesystemEpoch;
	    } else {
		srcFsPathPtr->filesystemEpoch = 0;
	    }
	    Tcl_DecrRefCount(translatedCwdPtr);
	} else {
	    /*
	     * It is a pure absolute, normalized path object. This is
	     * something like being a 'pure list'. The object's string,
	     * translatedPath and normalizedPath are all identical.
	     */

	    retObj = srcFsPathPtr->normPathPtr;
	}
    } else {
	/*
	 * It is an ordinary path object.
	 */

	retObj = srcFsPathPtr->translatedPathPtr;







<
<
<
<
<
<
<
<







1611
1612
1613
1614
1615
1616
1617








1618
1619
1620
1621
1622
1623
1624
	    if (translatedCwdIrPtr) {
		srcFsPathPtr->filesystemEpoch
			= PATHOBJ(translatedCwdPtr)->filesystemEpoch;
	    } else {
		srcFsPathPtr->filesystemEpoch = 0;
	    }
	    Tcl_DecrRefCount(translatedCwdPtr);








	}
    } else {
	/*
	 * It is an ordinary path object.
	 */

	retObj = srcFsPathPtr->translatedPathPtr;
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826

	    fsPathPtr->cwdPtr = origDirFsPathPtr->cwdPtr;
	    Tcl_IncrRefCount(fsPathPtr->cwdPtr);

	    TclDecrRefCount(fsPathPtr->normPathPtr);
	    fsPathPtr->normPathPtr = copy;

	    /*
	     * That's our reference to copy used.
	     */
	    copy = NULL;

	    TclDecrRefCount(dir);
	    TclDecrRefCount(origDir);
	} else {
	    TclDecrRefCount(fsPathPtr->cwdPtr);
	    fsPathPtr->cwdPtr = NULL;
	    TclDecrRefCount(fsPathPtr->normPathPtr);
	    fsPathPtr->normPathPtr = copy;

	    /*
	     * That's our reference to copy used.
	     */
	    copy = NULL;
	    TclDecrRefCount(dir);
	}
	PATHFLAGS(pathPtr) = 0;
    }

    /*
     * Ensure cwd hasn't changed.







<
<
<
<
<








<
<
<
<







1778
1779
1780
1781
1782
1783
1784





1785
1786
1787
1788
1789
1790
1791
1792




1793
1794
1795
1796
1797
1798
1799

	    fsPathPtr->cwdPtr = origDirFsPathPtr->cwdPtr;
	    Tcl_IncrRefCount(fsPathPtr->cwdPtr);

	    TclDecrRefCount(fsPathPtr->normPathPtr);
	    fsPathPtr->normPathPtr = copy;






	    TclDecrRefCount(dir);
	    TclDecrRefCount(origDir);
	} else {
	    TclDecrRefCount(fsPathPtr->cwdPtr);
	    fsPathPtr->cwdPtr = NULL;
	    TclDecrRefCount(fsPathPtr->normPathPtr);
	    fsPathPtr->normPathPtr = copy;





	    TclDecrRefCount(dir);
	}
	PATHFLAGS(pathPtr) = 0;
    }

    /*
     * Ensure cwd hasn't changed.
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
	    Tcl_IncrRefCount(fsPathPtr->normPathPtr);
	}
    }
    if (fsPathPtr->normPathPtr == NULL) {
	Tcl_Obj *useThisCwd = NULL;

	/*
	 * Since normPathPtr is NULL, but this is a valid path object, we know
	 * that the translatedPathPtr cannot be NULL.
	 */

	Tcl_Obj *absolutePath = fsPathPtr->translatedPathPtr;
	const char *path = TclGetString(absolutePath);

	Tcl_IncrRefCount(absolutePath);







|







1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
	    Tcl_IncrRefCount(fsPathPtr->normPathPtr);
	}
    }
    if (fsPathPtr->normPathPtr == NULL) {
	Tcl_Obj *useThisCwd = NULL;

	/*
	 * Since normPathPtr is NULL but this is a valid path object, we know
	 * that the translatedPathPtr cannot be NULL.
	 */

	Tcl_Obj *absolutePath = fsPathPtr->translatedPathPtr;
	const char *path = TclGetString(absolutePath);

	Tcl_IncrRefCount(absolutePath);
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965

1966

1967
1968
1969
1970



1971
1972



1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993

1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014


2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSGetInternalRep --
 *
 *	Extract the internal representation of a given path object, in the
 *	given filesystem. If the path object belongs to a different
 *	filesystem, we return NULL.
 *
 *	If the internal representation is currently NULL, we attempt to
 *	generate it, by calling the filesystem's

 *	'Tcl_FSCreateInternalRepProc'.

 *
 * Results:
 *	NULL or a valid internal representation.
 *



 * Side effects:
 *	An attempt may be made to convert the object.



 *
 *---------------------------------------------------------------------------
 */

ClientData
Tcl_FSGetInternalRep(
    Tcl_Obj *pathPtr,
    const Tcl_Filesystem *fsPtr)
{
    FsPath *srcFsPathPtr;

    if (Tcl_FSConvertToPathType(NULL, pathPtr) != TCL_OK) {
	return NULL;
    }
    srcFsPathPtr = PATHOBJ(pathPtr);

    /*
     * We will only return the native representation for the caller's
     * filesystem. Otherwise we will simply return NULL. This means that there
     * must be a unique bi-directional mapping between paths and filesystems,
     * and that this mapping will not allow 'remapped' files -- files which

     * are in one filesystem but mapped into another. Another way of putting
     * this is that 'stacked' filesystems are not allowed. We recognise that
     * this is a potentially useful feature for the future.
     *
     * Even something simple like a 'pass through' filesystem which logs all
     * activity and passes the calls onto the native system would be nice, but
     * not easily achievable with the current implementation.
     */

    if (srcFsPathPtr->fsPtr == NULL) {
	/*
	 * This only usually happens in wrappers like TclpStat which create a
	 * string object and pass it to TclpObjStat. Code which calls the
	 * Tcl_FS.. functions should always have a filesystem already set.
	 * Whether this code path is legal or not depends on whether we decide
	 * to allow external code to call the native filesystem directly. It
	 * is at least safer to allow this sub-optimal routing.
	 */

	Tcl_FSGetFileSystemForPath(pathPtr);



	/*
	 * If we fail through here, then the path is probably not a valid path
	 * in the filesystsem, and is most likely to be a use of the empty
	 * path "" via a direct call to one of the objectified interfaces
	 * (e.g. from the Tcl testsuite).
	 */

	srcFsPathPtr = PATHOBJ(pathPtr);
	if (srcFsPathPtr->fsPtr == NULL) {
	    return NULL;
	}
    }

    /*
     * There is still one possibility we should consider; if the file belongs
     * to a different filesystem, perhaps it is actually linked through to a
     * file in our own filesystem which we do care about. The way we can check
     * for this is we ask what filesystem this path belongs to.
     */

    if (fsPtr != srcFsPathPtr->fsPtr) {
	const Tcl_Filesystem *actualFs = Tcl_FSGetFileSystemForPath(pathPtr);

	if (actualFs == fsPtr) {
	    return Tcl_FSGetInternalRep(pathPtr, fsPtr);







|
<
|

<
|
>
|
>


<

>
>
>

<
>
>
>

















<
<
|
<
>
|
|
|



|



<
<
<
<
<
<
<
<
<


>
>
|
|
|
|
|
|
<
<
<





<
|
|
|







1926
1927
1928
1929
1930
1931
1932
1933

1934
1935

1936
1937
1938
1939
1940
1941

1942
1943
1944
1945
1946

1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966


1967

1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978









1979
1980
1981
1982
1983
1984
1985
1986
1987
1988



1989
1990
1991
1992
1993

1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSGetInternalRep --
 *
 *	Produces a native representation of a given path object in the given

 *	filesystem.
 *

 *	In the future it might be desirable to have separate versions
 *	of this function with different signatures, for example
 *	Tcl_FSGetNativeWinPath, Tcl_FSGetNativeUnixPath etc. Right now, since
 *	native paths are all string based, we use just one function.
 *
 * Results:

 *
 *	The native handle for the path, or NULL if the path is not handled by
 *	the given filesystem
 *
 * Side effects:

 *
 *	Tcl_FSCreateInternalRepProc if needed to produce the native
 *	handle, which is then stored in the internal representation of pathPtr.
 *
 *---------------------------------------------------------------------------
 */

ClientData
Tcl_FSGetInternalRep(
    Tcl_Obj *pathPtr,
    const Tcl_Filesystem *fsPtr)
{
    FsPath *srcFsPathPtr;

    if (Tcl_FSConvertToPathType(NULL, pathPtr) != TCL_OK) {
	return NULL;
    }
    srcFsPathPtr = PATHOBJ(pathPtr);

    /*


     * Currently there must be a unique bi-directional mapping between a path

     * and a filesystem, and therefore there is no way to "remap" a file, i.e.,
     * to map a file in one filesystem into another. Another way of putting
     * this is that 'stacked' filesystems are not allowed.  It could be useful
     * in the future to redesign the system to allow that.
     *
     * Even something simple like a 'pass through' filesystem which logs all
     * activity and passes the calls onto the native system would be nice, but
     * not currently easily achievable.
     */

    if (srcFsPathPtr->fsPtr == NULL) {









	Tcl_FSGetFileSystemForPath(pathPtr);

	srcFsPathPtr = PATHOBJ(pathPtr);
	if (srcFsPathPtr->fsPtr == NULL) {
	    /*
	     * The path is probably not a valid path in the filesystsem, and is
	     * most likely to be a use of the empty path "" via a direct call
	     * to one of the objectified interfaces (e.g. from the Tcl
	     * testsuite).
	     */



	    return NULL;
	}
    }

    /*

     * If the file belongs to a different filesystem, perhaps it is actually
     * linked through to a file in the given filesystem. Check this by
     * inspecting the filesystem associated with the given path.
     */

    if (fsPtr != srcFsPathPtr->fsPtr) {
	const Tcl_Filesystem *actualFs = Tcl_FSGetFileSystemForPath(pathPtr);

	if (actualFs == fsPtr) {
	    return Tcl_FSGetInternalRep(pathPtr, fsPtr);
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069

2070
2071
2072
2073
2074
2075

2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092

2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110

2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
}

/*
 *---------------------------------------------------------------------------
 *
 * TclFSEnsureEpochOk --
 *
 *	This will ensure the pathPtr is up to date and can be converted into a
 *	"path" type, and that we are able to generate a complete normalized
 *	path which is used to determine the filesystem match.

 *
 * Results:
 *	Standard Tcl return code.
 *
 * Side effects:
 *	An attempt may be made to convert the object.

 *
 *---------------------------------------------------------------------------
 */

int
TclFSEnsureEpochOk(
    Tcl_Obj *pathPtr,
    const Tcl_Filesystem **fsPtrPtr)
{
    FsPath *srcFsPathPtr;

    if (!TclHasIntRep(pathPtr, &fsPathType)) {
	return TCL_OK;
    }

    srcFsPathPtr = PATHOBJ(pathPtr);


    /*
     * Check if the filesystem has changed in some way since this object's
     * internal representation was calculated.
     */

    if (!TclFSEpochOk(srcFsPathPtr->filesystemEpoch)) {
	/*
	 * We have to discard the stale representation and recalculate it.
	 */

	TclGetString(pathPtr);
	Tcl_StoreIntRep(pathPtr, &fsPathType, NULL);
	if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) {
	    return TCL_ERROR;
	}
	srcFsPathPtr = PATHOBJ(pathPtr);
    }


    /*
     * Check whether the object is already assigned to a fs.
     */

    if (srcFsPathPtr->fsPtr != NULL) {
	*fsPtrPtr = srcFsPathPtr->fsPtr;
    }
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------







<
|
<
>


|


|
>

















>
|
|
<
<
|
<
<
|










>
|
|
|
<
<







2024
2025
2026
2027
2028
2029
2030

2031

2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059


2060


2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075


2076
2077
2078
2079
2080
2081
2082
}

/*
 *---------------------------------------------------------------------------
 *
 * TclFSEnsureEpochOk --
 *

 *	Ensure that the path is a valid path, and that it has a 

 *	fsPathType internal representation that is not stale.
 *
 * Results:
 *	A standard Tcl return code.
 *
 * Side effects:
 *	The internal representation of fsPtrPtr is converted to fsPathType if
 *	possible.
 *
 *---------------------------------------------------------------------------
 */

int
TclFSEnsureEpochOk(
    Tcl_Obj *pathPtr,
    const Tcl_Filesystem **fsPtrPtr)
{
    FsPath *srcFsPathPtr;

    if (!TclHasIntRep(pathPtr, &fsPathType)) {
	return TCL_OK;
    }

    srcFsPathPtr = PATHOBJ(pathPtr);

    if (!TclFSEpochOk(srcFsPathPtr->filesystemEpoch)) {
	/*
	 * The filesystem has changed in some way since the internal


	 * representation for this object was calculated. Discard the stale


	 * representation and recalculate it.
	 */

	TclGetString(pathPtr);
	Tcl_StoreIntRep(pathPtr, &fsPathType, NULL);
	if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) {
	    return TCL_ERROR;
	}
	srcFsPathPtr = PATHOBJ(pathPtr);
    }

    if (srcFsPathPtr->fsPtr != NULL) {
	/*
	 * There is already a filesystem assigned to this path.
	 */


	*fsPtrPtr = srcFsPathPtr->fsPtr;
    }
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225

2226
2227
2228
2229
2230
2231
2232
2233
2234
}

/*
 *---------------------------------------------------------------------------
 *
 * SetFsPathFromAny --
 *
 *	This function tries to convert the given Tcl_Obj to a valid Tcl path
 *	type.
 *

 *	The filename may begin with "~" (to indicate current user's home
 *	directory) or "~<user>" (to indicate any user's home directory).
 *
 * Results:
 *	Standard Tcl error code.
 *
 * Side effects:
 *	The old representation may be freed, and new memory allocated.
 *







|
|

>
|
|







2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
}

/*
 *---------------------------------------------------------------------------
 *
 * SetFsPathFromAny --
 *
 *	Attempt to convert the internal representation of pathPtr to
 *	fsPathType.
 *
 *	A tilde ("~") character at the beginnig of the filename indicates the
 *	current user's home directory, and "~<user>" indicates a particular
 *	user's directory.
 *
 * Results:
 *	Standard Tcl error code.
 *
 * Side effects:
 *	The old representation may be freed, and new memory allocated.
 *
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
		return TCL_ERROR;
	    }
	    Tcl_DStringInit(&temp);
	    Tcl_JoinPath(1, &dir, &temp);
	    Tcl_DStringFree(&dirString);
	} else {
	    /*
	     * We have a user name '~user'
	     */

	    const char *expandedUser;
	    Tcl_DString userName;

	    Tcl_DStringInit(&userName);
	    Tcl_DStringAppend(&userName, name+1, split-1);







|







2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
		return TCL_ERROR;
	    }
	    Tcl_DStringInit(&temp);
	    Tcl_JoinPath(1, &dir, &temp);
	    Tcl_DStringFree(&dirString);
	} else {
	    /*
	     * There is a '~user'
	     */

	    const char *expandedUser;
	    Tcl_DString userName;

	    Tcl_DStringInit(&userName);
	    Tcl_DStringAppend(&userName, name+1, split-1);
Changes to generic/tclStubInit.c.
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
   mp_digit d2;
   mp_err result = TclBN_s_mp_div_d(a, b, c, (d ? &d2 : NULL));
   if (d) {
      *d = d2;
   }
   return result;
}
mp_err TclBN_mp_div_3(const mp_int *a, mp_int *c, unsigned int *d) {
   mp_digit d2;
   mp_err result = TclBN_s_mp_div_3(a, c, &d2);
   if (d) {
      *d = d2;
   }
   return result;
}
mp_err TclBN_mp_init_set(mp_int *a, unsigned int b) {
	return TclBN_s_mp_init_set(a, b);
}
mp_err	TclBN_mp_mul_d(const mp_int *a, unsigned int b, mp_int *c) {
	return TclBN_s_mp_mul_d(a, b, c);
}
void TclBN_mp_set(mp_int *a, unsigned int b) {
	TclBN_s_mp_set(a, b);
}



#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8
#   define TclBN_mp_expt_d_ex 0
#   define TclBN_mp_to_unsigned_bin 0
#   define TclBN_mp_to_unsigned_bin_n 0
#   define TclBN_mp_toradix_n 0


#   define TclSetStartupScriptPath 0
#   define TclGetStartupScriptPath 0
#   define TclSetStartupScriptFileName 0
#   define TclGetStartupScriptFileName 0
#   define TclPrecTraceProc 0
#   define TclpInetNtoa 0
#   define TclWinGetServByName 0







<
<
<
<
<
<
<
<

















>
>







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
   mp_digit d2;
   mp_err result = TclBN_s_mp_div_d(a, b, c, (d ? &d2 : NULL));
   if (d) {
      *d = d2;
   }
   return result;
}








mp_err TclBN_mp_init_set(mp_int *a, unsigned int b) {
	return TclBN_s_mp_init_set(a, b);
}
mp_err	TclBN_mp_mul_d(const mp_int *a, unsigned int b, mp_int *c) {
	return TclBN_s_mp_mul_d(a, b, c);
}
void TclBN_mp_set(mp_int *a, unsigned int b) {
	TclBN_s_mp_set(a, b);
}



#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8
#   define TclBN_mp_expt_d_ex 0
#   define TclBN_mp_to_unsigned_bin 0
#   define TclBN_mp_to_unsigned_bin_n 0
#   define TclBN_mp_toradix_n 0
#   define TclBN_mp_sqr 0
#   define TclBN_mp_div_3 0
#   define TclSetStartupScriptPath 0
#   define TclGetStartupScriptPath 0
#   define TclSetStartupScriptFileName 0
#   define TclGetStartupScriptFileName 0
#   define TclPrecTraceProc 0
#   define TclpInetNtoa 0
#   define TclWinGetServByName 0
173
174
175
176
177
178
179









180
181
182
183
184
185
186
#   define Tcl_SetIntObj 0
#   define Tcl_SetLongObj 0
#   define Tcl_NewIntObj 0
#   define Tcl_NewLongObj 0
#   define Tcl_DbNewLongObj 0
#   define Tcl_BackgroundError 0
#else










int TclBN_mp_expt_d_ex(const mp_int *a, unsigned int b, mp_int *c, int fast)
{
	return mp_expt_u32(a, b, c);
}

mp_err mp_to_unsigned_bin(const mp_int *a, unsigned char *b)







>
>
>
>
>
>
>
>
>







167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
#   define Tcl_SetIntObj 0
#   define Tcl_SetLongObj 0
#   define Tcl_NewIntObj 0
#   define Tcl_NewLongObj 0
#   define Tcl_DbNewLongObj 0
#   define Tcl_BackgroundError 0
#else

mp_err TclBN_mp_div_3(const mp_int *a, mp_int *c, unsigned int *d) {
   mp_digit d2;
   mp_err result = TclBN_s_mp_div_3(a, c, &d2);
   if (d) {
      *d = d2;
   }
   return result;
}

int TclBN_mp_expt_d_ex(const mp_int *a, unsigned int b, mp_int *c, int fast)
{
	return mp_expt_u32(a, b, c);
}

mp_err mp_to_unsigned_bin(const mp_int *a, unsigned char *b)
Changes to generic/tclTomMath.decls.
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
}
declare 15 {
    mp_err MP_WUR TclBN_mp_div_2(const mp_int *a, mp_int *q)
}
declare 16 {
    mp_err MP_WUR TclBN_mp_div_2d(const mp_int *a, int b, mp_int *q, mp_int *r)
}
declare 17 {
    mp_err MP_WUR TclBN_mp_div_3(const mp_int *a, mp_int *q, unsigned int *r)
}
declare 18 {
    void TclBN_mp_exch(mp_int *a, mp_int *b)
}
declare 19 {
    mp_err MP_WUR TclBN_mp_expt_u32(const mp_int *a, unsigned int b, mp_int *c)







|







70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
}
declare 15 {
    mp_err MP_WUR TclBN_mp_div_2(const mp_int *a, mp_int *q)
}
declare 16 {
    mp_err MP_WUR TclBN_mp_div_2d(const mp_int *a, int b, mp_int *q, mp_int *r)
}
declare 17 {deprecated {is private function in libtommath}} {
    mp_err MP_WUR TclBN_mp_div_3(const mp_int *a, mp_int *q, unsigned int *r)
}
declare 18 {
    void TclBN_mp_exch(mp_int *a, mp_int *b)
}
declare 19 {
    mp_err MP_WUR TclBN_mp_expt_u32(const mp_int *a, unsigned int b, mp_int *c)
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
}
declare 38 {
    mp_err MP_WUR TclBN_mp_shrink(mp_int *a)
}
declare 39 {
    void TclBN_mp_set(mp_int *a, unsigned int b)
}
declare 40 {
    mp_err MP_WUR TclBN_mp_sqr(const mp_int *a, mp_int *b)
}
declare 41 {
    mp_err MP_WUR TclBN_mp_sqrt(const mp_int *a, mp_int *b)
}
declare 42 {
    mp_err MP_WUR TclBN_mp_sub(const mp_int *a, const mp_int *b, mp_int *c)







|







139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
}
declare 38 {
    mp_err MP_WUR TclBN_mp_shrink(mp_int *a)
}
declare 39 {
    void TclBN_mp_set(mp_int *a, unsigned int b)
}
declare 40 {nostub {is private function in libtommath}} {
    mp_err MP_WUR TclBN_mp_sqr(const mp_int *a, mp_int *b)
}
declare 41 {
    mp_err MP_WUR TclBN_mp_sqrt(const mp_int *a, mp_int *b)
}
declare 42 {
    mp_err MP_WUR TclBN_mp_sub(const mp_int *a, const mp_int *b, mp_int *c)
Changes to generic/tclTomMathDecls.h.
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
#define mp_rshd TclBN_mp_rshd
#define mp_set_int(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_set_ul") (TclBN_mp_set_ul((a),((unsigned int)(b))),MP_OKAY))
#define mp_set_long(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_set_ul") (TclBN_mp_set_ul((a),(b)),MP_OKAY))
#define mp_set_long_long(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_set_ull") (TclBN_mp_set_ull((a),(b)),MP_OKAY))
#define mp_set_ul TclBN_mp_set_ul
#define mp_set_ull TclBN_mp_set_ull
#define mp_shrink TclBN_mp_shrink
#define mp_sqr TclBN_mp_sqr
#define mp_sqrt TclBN_mp_sqrt
#define mp_sub TclBN_mp_sub
#define mp_signed_rsh TclBN_mp_signed_rsh
#define mp_tc_and TclBN_mp_and
#define mp_tc_div_2d TclBN_mp_signed_rsh
#define mp_tc_or TclBN_mp_or
#define mp_tc_xor TclBN_mp_xor







<







102
103
104
105
106
107
108

109
110
111
112
113
114
115
#define mp_rshd TclBN_mp_rshd
#define mp_set_int(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_set_ul") (TclBN_mp_set_ul((a),((unsigned int)(b))),MP_OKAY))
#define mp_set_long(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_set_ul") (TclBN_mp_set_ul((a),(b)),MP_OKAY))
#define mp_set_long_long(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_set_ull") (TclBN_mp_set_ull((a),(b)),MP_OKAY))
#define mp_set_ul TclBN_mp_set_ul
#define mp_set_ull TclBN_mp_set_ull
#define mp_shrink TclBN_mp_shrink

#define mp_sqrt TclBN_mp_sqrt
#define mp_sub TclBN_mp_sub
#define mp_signed_rsh TclBN_mp_signed_rsh
#define mp_tc_and TclBN_mp_and
#define mp_tc_div_2d TclBN_mp_signed_rsh
#define mp_tc_or TclBN_mp_or
#define mp_tc_xor TclBN_mp_xor
201
202
203
204
205
206
207

208
209
210
211
212
213
214
215
				mp_int *q, unsigned int *r) MP_WUR;
/* 15 */
EXTERN mp_err		TclBN_mp_div_2(const mp_int *a, mp_int *q) MP_WUR;
/* 16 */
EXTERN mp_err		TclBN_mp_div_2d(const mp_int *a, int b, mp_int *q,
				mp_int *r) MP_WUR;
/* 17 */

EXTERN mp_err		TclBN_mp_div_3(const mp_int *a, mp_int *q,
				unsigned int *r) MP_WUR;
/* 18 */
EXTERN void		TclBN_mp_exch(mp_int *a, mp_int *b);
/* 19 */
EXTERN mp_err		TclBN_mp_expt_u32(const mp_int *a, unsigned int b,
				mp_int *c) MP_WUR;
/* 20 */







>
|







200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
				mp_int *q, unsigned int *r) MP_WUR;
/* 15 */
EXTERN mp_err		TclBN_mp_div_2(const mp_int *a, mp_int *q) MP_WUR;
/* 16 */
EXTERN mp_err		TclBN_mp_div_2d(const mp_int *a, int b, mp_int *q,
				mp_int *r) MP_WUR;
/* 17 */
TCL_DEPRECATED("is private function in libtommath")
mp_err MP_WUR		TclBN_mp_div_3(const mp_int *a, mp_int *q,
				unsigned int *r) MP_WUR;
/* 18 */
EXTERN void		TclBN_mp_exch(mp_int *a, mp_int *b);
/* 19 */
EXTERN mp_err		TclBN_mp_expt_u32(const mp_int *a, unsigned int b,
				mp_int *c) MP_WUR;
/* 20 */
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
    mp_ord (*tclBN_mp_cmp_mag) (const mp_int *a, const mp_int *b) MP_WUR; /* 10 */
    mp_err (*tclBN_mp_copy) (const mp_int *a, mp_int *b) MP_WUR; /* 11 */
    int (*tclBN_mp_count_bits) (const mp_int *a) MP_WUR; /* 12 */
    mp_err (*tclBN_mp_div) (const mp_int *a, const mp_int *b, mp_int *q, mp_int *r) MP_WUR; /* 13 */
    mp_err (*tclBN_mp_div_d) (const mp_int *a, unsigned int b, mp_int *q, unsigned int *r) MP_WUR; /* 14 */
    mp_err (*tclBN_mp_div_2) (const mp_int *a, mp_int *q) MP_WUR; /* 15 */
    mp_err (*tclBN_mp_div_2d) (const mp_int *a, int b, mp_int *q, mp_int *r) MP_WUR; /* 16 */
    mp_err (*tclBN_mp_div_3) (const mp_int *a, mp_int *q, unsigned int *r) MP_WUR; /* 17 */
    void (*tclBN_mp_exch) (mp_int *a, mp_int *b); /* 18 */
    mp_err (*tclBN_mp_expt_u32) (const mp_int *a, unsigned int b, mp_int *c) MP_WUR; /* 19 */
    mp_err (*tclBN_mp_grow) (mp_int *a, int size) MP_WUR; /* 20 */
    mp_err (*tclBN_mp_init) (mp_int *a) MP_WUR; /* 21 */
    mp_err (*tclBN_mp_init_copy) (mp_int *a, const mp_int *b) MP_WUR; /* 22 */
    mp_err (*tclBN_mp_init_multi) (mp_int *a, ...) MP_WUR; /* 23 */
    mp_err (*tclBN_mp_init_set) (mp_int *a, unsigned int b) MP_WUR; /* 24 */







|







395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
    mp_ord (*tclBN_mp_cmp_mag) (const mp_int *a, const mp_int *b) MP_WUR; /* 10 */
    mp_err (*tclBN_mp_copy) (const mp_int *a, mp_int *b) MP_WUR; /* 11 */
    int (*tclBN_mp_count_bits) (const mp_int *a) MP_WUR; /* 12 */
    mp_err (*tclBN_mp_div) (const mp_int *a, const mp_int *b, mp_int *q, mp_int *r) MP_WUR; /* 13 */
    mp_err (*tclBN_mp_div_d) (const mp_int *a, unsigned int b, mp_int *q, unsigned int *r) MP_WUR; /* 14 */
    mp_err (*tclBN_mp_div_2) (const mp_int *a, mp_int *q) MP_WUR; /* 15 */
    mp_err (*tclBN_mp_div_2d) (const mp_int *a, int b, mp_int *q, mp_int *r) MP_WUR; /* 16 */
    TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_mp_div_3) (const mp_int *a, mp_int *q, unsigned int *r) MP_WUR; /* 17 */
    void (*tclBN_mp_exch) (mp_int *a, mp_int *b); /* 18 */
    mp_err (*tclBN_mp_expt_u32) (const mp_int *a, unsigned int b, mp_int *c) MP_WUR; /* 19 */
    mp_err (*tclBN_mp_grow) (mp_int *a, int size) MP_WUR; /* 20 */
    mp_err (*tclBN_mp_init) (mp_int *a) MP_WUR; /* 21 */
    mp_err (*tclBN_mp_init_copy) (mp_int *a, const mp_int *b) MP_WUR; /* 22 */
    mp_err (*tclBN_mp_init_multi) (mp_int *a, ...) MP_WUR; /* 23 */
    mp_err (*tclBN_mp_init_set) (mp_int *a, unsigned int b) MP_WUR; /* 24 */
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
    mp_err (*tclBN_mp_neg) (const mp_int *a, mp_int *b) MP_WUR; /* 33 */
    mp_err (*tclBN_mp_or) (const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* 34 */
    mp_err (*tclBN_mp_radix_size) (const mp_int *a, int radix, int *size) MP_WUR; /* 35 */
    mp_err (*tclBN_mp_read_radix) (mp_int *a, const char *str, int radix) MP_WUR; /* 36 */
    void (*tclBN_mp_rshd) (mp_int *a, int shift); /* 37 */
    mp_err (*tclBN_mp_shrink) (mp_int *a) MP_WUR; /* 38 */
    void (*tclBN_mp_set) (mp_int *a, unsigned int b); /* 39 */
    mp_err (*tclBN_mp_sqr) (const mp_int *a, mp_int *b) MP_WUR; /* 40 */
    mp_err (*tclBN_mp_sqrt) (const mp_int *a, mp_int *b) MP_WUR; /* 41 */
    mp_err (*tclBN_mp_sub) (const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* 42 */
    mp_err (*tclBN_mp_sub_d) (const mp_int *a, unsigned int b, mp_int *c) MP_WUR; /* 43 */
    TCL_DEPRECATED_API("Use mp_to_ubin") mp_err (*tclBN_mp_to_unsigned_bin) (const mp_int *a, unsigned char *b); /* 44 */
    TCL_DEPRECATED_API("Use mp_to_ubin") mp_err (*tclBN_mp_to_unsigned_bin_n) (const mp_int *a, unsigned char *b, unsigned long *outlen); /* 45 */
    TCL_DEPRECATED_API("Use mp_to_radix") mp_err (*tclBN_mp_toradix_n) (const mp_int *a, char *str, int radix, int maxlen); /* 46 */
    size_t (*tclBN_mp_ubin_size) (const mp_int *a); /* 47 */







|







418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
    mp_err (*tclBN_mp_neg) (const mp_int *a, mp_int *b) MP_WUR; /* 33 */
    mp_err (*tclBN_mp_or) (const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* 34 */
    mp_err (*tclBN_mp_radix_size) (const mp_int *a, int radix, int *size) MP_WUR; /* 35 */
    mp_err (*tclBN_mp_read_radix) (mp_int *a, const char *str, int radix) MP_WUR; /* 36 */
    void (*tclBN_mp_rshd) (mp_int *a, int shift); /* 37 */
    mp_err (*tclBN_mp_shrink) (mp_int *a) MP_WUR; /* 38 */
    void (*tclBN_mp_set) (mp_int *a, unsigned int b); /* 39 */
    TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_mp_sqr) (const mp_int *a, mp_int *b) MP_WUR; /* 40 */
    mp_err (*tclBN_mp_sqrt) (const mp_int *a, mp_int *b) MP_WUR; /* 41 */
    mp_err (*tclBN_mp_sub) (const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* 42 */
    mp_err (*tclBN_mp_sub_d) (const mp_int *a, unsigned int b, mp_int *c) MP_WUR; /* 43 */
    TCL_DEPRECATED_API("Use mp_to_ubin") mp_err (*tclBN_mp_to_unsigned_bin) (const mp_int *a, unsigned char *b); /* 44 */
    TCL_DEPRECATED_API("Use mp_to_ubin") mp_err (*tclBN_mp_to_unsigned_bin_n) (const mp_int *a, unsigned char *b, unsigned long *outlen); /* 45 */
    TCL_DEPRECATED_API("Use mp_to_radix") mp_err (*tclBN_mp_toradix_n) (const mp_int *a, char *str, int radix, int maxlen); /* 46 */
    size_t (*tclBN_mp_ubin_size) (const mp_int *a); /* 47 */
661
662
663
664
665
666
667
668






669
#define mp_mul_d TclBN_s_mp_mul_d
#define mp_set TclBN_s_mp_set
#define mp_expt_u32 TclBN_s_mp_expt_u32
#endif /* !BUILD_tcl */

#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT







#endif /* _TCLINTDECLS */








>
>
>
>
>
>

661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
#define mp_mul_d TclBN_s_mp_mul_d
#define mp_set TclBN_s_mp_set
#define mp_expt_u32 TclBN_s_mp_expt_u32
#endif /* !BUILD_tcl */

#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT

#if defined(USE_TCL_STUBS)
#   define mp_sqr(a,b) mp_mul(a,a,b)
#else
#   define mp_sqr TclBN_mp_sqr
#endif

#endif /* _TCLINTDECLS */
Changes to libtommath/bn_mp_mul.c.
8
9
10
11
12
13
14


15
16
17
18
19
20
21
22
{
   mp_err err;
   int min_len = MP_MIN(a->used, b->used),
       max_len = MP_MAX(a->used, b->used),
       digs = a->used + b->used + 1;
   mp_sign neg = (a->sign == b->sign) ? MP_ZPOS : MP_NEG;



   if (MP_HAS(S_MP_BALANCE_MUL) &&
       /* Check sizes. The smaller one needs to be larger than the Karatsuba cut-off.
        * The bigger one needs to be at least about one MP_KARATSUBA_MUL_CUTOFF bigger
        * to make some sense, but it depends on architecture, OS, position of the
        * stars... so YMMV.
        * Using it to cut the input into slices small enough for s_mp_mul_digs_fast
        * was actually slower on the author's machine, but YMMV.
        */







>
>
|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
{
   mp_err err;
   int min_len = MP_MIN(a->used, b->used),
       max_len = MP_MAX(a->used, b->used),
       digs = a->used + b->used + 1;
   mp_sign neg = (a->sign == b->sign) ? MP_ZPOS : MP_NEG;

   if (a == b) {
       return mp_sqr(a,c);
   } else if (MP_HAS(S_MP_BALANCE_MUL) &&
       /* Check sizes. The smaller one needs to be larger than the Karatsuba cut-off.
        * The bigger one needs to be at least about one MP_KARATSUBA_MUL_CUTOFF bigger
        * to make some sense, but it depends on architecture, OS, position of the
        * stars... so YMMV.
        * Using it to cut the input into slices small enough for s_mp_mul_digs_fast
        * was actually slower on the author's machine, but YMMV.
        */
Changes to tests/cmdMZ.test.
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
    namespace import ::tcltest::customMatch
    namespace import ::tcltest::makeFile
    namespace import ::tcltest::removeFile
    namespace import ::tcltest::temporaryDirectory
    namespace import ::tcltest::testConstraint
    namespace import ::tcltest::test

    testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}]

    proc ListGlobMatch {expected actual} {
	if {[llength $expected] != [llength $actual]} {
	    return 0
	}
	foreach e $expected a $actual {
	    if {![string match $e $a]} {
		return 0







<
<







21
22
23
24
25
26
27


28
29
30
31
32
33
34
    namespace import ::tcltest::customMatch
    namespace import ::tcltest::makeFile
    namespace import ::tcltest::removeFile
    namespace import ::tcltest::temporaryDirectory
    namespace import ::tcltest::testConstraint
    namespace import ::tcltest::test



    proc ListGlobMatch {expected actual} {
	if {[llength $expected] != [llength $actual]} {
	    return 0
	}
	foreach e $expected a $actual {
	    if {![string match $e $a]} {
		return 0
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
# The tests for Tcl_SwitchObjCmd are in switch.test

# todo: rewrite this if monotonic clock is provided resp. command "after"
# gets microsecond accuracy (RFE [fdfbd5e10] gets merged):
proc _nrt_sleep {msec} {
    set usec [expr {$msec * 1000}]
    set stime [clock microseconds]
    while {abs([clock microseconds] - $stime) < $usec} {after 0}


}



test cmdMZ-5.1 {Tcl_TimeObjCmd: basic format of command} -body {
    time
} -returnCodes error -result {wrong # args: should be "time command ?count?"}
test cmdMZ-5.2 {Tcl_TimeObjCmd: basic format of command} -body {
    time a b c
} -returnCodes error -result {wrong # args: should be "time command ?count?"}
test cmdMZ-5.3 {Tcl_TimeObjCmd: basic format of command} -body {
    time a b
} -returnCodes error -result {expected integer but got "b"}
test cmdMZ-5.4 {Tcl_TimeObjCmd: nothing happens with negative iteration counts} {
    time bogusCmd -12456
} {0 microseconds per iteration}
test cmdMZ-5.5 {Tcl_TimeObjCmd: result format} -body {
    time {format 1}
} -match regexp -result {^\d+ microseconds per iteration}
test cmdMZ-5.6 {Tcl_TimeObjCmd: slower commands take longer} knownMsvcBug {
    expr {[lindex [time {_nrt_sleep 1}] 0] < [lindex [time {_nrt_sleep 20}] 0]}
} 1
test cmdMZ-5.7 {Tcl_TimeObjCmd: errors generate right trace} {
    list [catch {time {error foo}} msg] $msg $::errorInfo
} {1 foo {foo
    while executing
"error foo"
    invoked from within







|
>
>
|
>
>
















|
|







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
# The tests for Tcl_SwitchObjCmd are in switch.test

# todo: rewrite this if monotonic clock is provided resp. command "after"
# gets microsecond accuracy (RFE [fdfbd5e10] gets merged):
proc _nrt_sleep {msec} {
    set usec [expr {$msec * 1000}]
    set stime [clock microseconds]
    while {abs([clock microseconds] - $stime) < $usec} {
      # don't use after 0 unless it's NRT-capable, so yes - busy-wait (but it's more precise):
      # after 0
    }
}
_nrt_sleep 0; # warm up (clock, compile, etc)

test cmdMZ-5.1 {Tcl_TimeObjCmd: basic format of command} -body {
    time
} -returnCodes error -result {wrong # args: should be "time command ?count?"}
test cmdMZ-5.2 {Tcl_TimeObjCmd: basic format of command} -body {
    time a b c
} -returnCodes error -result {wrong # args: should be "time command ?count?"}
test cmdMZ-5.3 {Tcl_TimeObjCmd: basic format of command} -body {
    time a b
} -returnCodes error -result {expected integer but got "b"}
test cmdMZ-5.4 {Tcl_TimeObjCmd: nothing happens with negative iteration counts} {
    time bogusCmd -12456
} {0 microseconds per iteration}
test cmdMZ-5.5 {Tcl_TimeObjCmd: result format} -body {
    time {format 1}
} -match regexp -result {^\d+ microseconds per iteration}
test cmdMZ-5.6 {Tcl_TimeObjCmd: slower commands take longer} {
    expr {[lindex [time {_nrt_sleep 0.01}] 0] < [lindex [time {_nrt_sleep 10.0}] 0]}
} 1
test cmdMZ-5.7 {Tcl_TimeObjCmd: errors generate right trace} {
    list [catch {time {error foo}} msg] $msg $::errorInfo
} {1 foo {foo
    while executing
"error foo"
    invoked from within
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
} {1 {missing close-brace}}
test cmdMZ-6.5a {Tcl_TimeRateObjCmd: result format and one iteration} {
    regexp {^\d+(?:\.\d+)? \ws/# 1 # \d+(?:\.\d+)? #/sec \d+(?:\.\d+)? net-ms$} [timerate {} 0]
} 1
test cmdMZ-6.5b {Tcl_TimeRateObjCmd: result format without iterations} {
    regexp {^0 \ws/# 0 # 0 #/sec 0 net-ms$} [timerate {} 0 0]
} 1
test cmdMZ-6.6 {Tcl_TimeRateObjCmd: slower commands take longer, but it remains almost the same time of measument} knownMsvcBug {
    set m1 [timerate {_nrt_sleep 0} 20]

    set m2 [timerate {_nrt_sleep 0.2} 20]
    list \
	[expr {[lindex $m1 0] < [lindex $m2 0]}] \
	[expr {[lindex $m1 0] < 100}] \
	[expr {[lindex $m2 0] > 100}] \
	[expr {[lindex $m1 2] > 1000}] \
	[expr {[lindex $m2 2] < 1000}] \
	[expr {[lindex $m1 4] > 50000}] \
	[expr {[lindex $m2 4] < 50000}] \
	[expr {[lindex $m1 6] > 10 && [lindex $m1 6] < 100}] \
	[expr {[lindex $m2 6] > 10 && [lindex $m2 6] < 100}]
} [lrepeat 9 1]
test cmdMZ-6.7 {Tcl_TimeRateObjCmd: errors generate right trace} {
    list [catch {timerate {error foo} 1} msg] $msg $::errorInfo
} {1 foo {foo
    while executing
"error foo"
    invoked from within







|
|
>
|




|
|
|
|
|
|







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
} {1 {missing close-brace}}
test cmdMZ-6.5a {Tcl_TimeRateObjCmd: result format and one iteration} {
    regexp {^\d+(?:\.\d+)? \ws/# 1 # \d+(?:\.\d+)? #/sec \d+(?:\.\d+)? net-ms$} [timerate {} 0]
} 1
test cmdMZ-6.5b {Tcl_TimeRateObjCmd: result format without iterations} {
    regexp {^0 \ws/# 0 # 0 #/sec 0 net-ms$} [timerate {} 0 0]
} 1
test cmdMZ-6.6 {Tcl_TimeRateObjCmd: slower commands take longer, but it remains almost the same time of measument} {
    lassign [timerate {_nrt_sleep 0} 50] ovh
    set m1 [timerate -overhead $ovh {_nrt_sleep 0.01} 50]
    set m2 [timerate -overhead $ovh {_nrt_sleep 1.00} 50]
    list \
	[expr {[lindex $m1 0] < [lindex $m2 0]}] \
	[expr {[lindex $m1 0] < 100}] \
	[expr {[lindex $m2 0] > 100}] \
	[expr {[lindex $m1 2] > 500}] \
	[expr {[lindex $m2 2] < 500}] \
	[expr {[lindex $m1 4] > 10000}] \
	[expr {[lindex $m2 4] < 10000}] \
	[expr {[lindex $m1 6] > 5 && [lindex $m1 6] < 100}] \
	[expr {[lindex $m2 6] > 5 && [lindex $m2 6] < 100}]
} [lrepeat 9 1]
test cmdMZ-6.7 {Tcl_TimeRateObjCmd: errors generate right trace} {
    list [catch {timerate {error foo} 1} msg] $msg $::errorInfo
} {1 foo {foo
    while executing
"error foo"
    invoked from within
Changes to unix/tclLoadDl.c.
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
}

/*
 *----------------------------------------------------------------------
 *
 * UnloadFile --
 *
 *	Unloads a dynamically loaded binary code file from memory. Code
 *	pointers in the formerly loaded file are no longer valid after calling
 *	this function.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Code removed from memory.
 *
 *----------------------------------------------------------------------
 */

static void
UnloadFile(
    Tcl_LoadHandle loadHandle)	/* loadHandle returned by a previous call to







|
|
<





|







206
207
208
209
210
211
212
213
214

215
216
217
218
219
220
221
222
223
224
225
226
227
}

/*
 *----------------------------------------------------------------------
 *
 * UnloadFile --
 *
 *	Unloads a dynamic shared object, after which all pointers to functions
 *	in the formerly-loaded object are no longer valid.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Memory for the loaded object is deallocated.
 *
 *----------------------------------------------------------------------
 */

static void
UnloadFile(
    Tcl_LoadHandle loadHandle)	/* loadHandle returned by a previous call to
Changes to unix/tclUnixFCmd.c.
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931

1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943

1944





1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967

1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981


1982



1983
1984
1985
1986
1987
1988
1989
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpObjNormalizePath --
 *
 *	This function scans through a path specification and replaces it, in
 *	place, with a normalized version. A normalized version is one in which
 *	all symlinks in the path are replaced with their expanded form (except
 *	a symlink at the very end of the path).
 *
 * Results:
 *	The new 'nextCheckpoint' value, giving as far as we could understand

 *	in the path.
 *
 * Side effects:
 *	The pathPtr string, is modified.
 *
 *---------------------------------------------------------------------------
 */

int
TclpObjNormalizePath(
    Tcl_Interp *interp,
    Tcl_Obj *pathPtr,

    int nextCheckpoint)





{
    const char *currentPathEndPosition;
    char cur;
    const char *path = TclGetString(pathPtr);
    size_t pathLen = pathPtr->length;
    Tcl_DString ds;
    const char *nativePath;
#ifndef NO_REALPATH
    char normPath[MAXPATHLEN];
#endif

    /*
     * We add '1' here because if nextCheckpoint is zero we know that '/'
     * exists, and if it isn't zero, it must point at a directory separator
     * which we also know exists.
     */

    currentPathEndPosition = path + nextCheckpoint;
    if (*currentPathEndPosition == '/') {
	currentPathEndPosition++;
    }

#ifndef NO_REALPATH

    /*
     * For speed, try to get the entire path in one go.
     */

    if (nextCheckpoint == 0 && haveRealpath) {
	char *lastDir = strrchr(currentPathEndPosition, '/');

	if (lastDir != NULL) {
	    nativePath = Tcl_UtfToExternalDString(NULL, path,
		    lastDir-path, &ds);
	    if (Realpath(nativePath, normPath) != NULL) {
		if (*nativePath != '/' && *normPath == '/') {
		    /*
		     * realpath has transformed a relative path into an


		     * absolute path, we do not know how to handle this.



		     */
		} else {
		    nextCheckpoint = lastDir - path;
		    goto wholeStringOk;
		}
	    }
	    Tcl_DStringFree(&ds);







|
<
|
<


<
>
|


<







|
>
|
>
>
>
>
>











<
<
<
<
<
<






>
|
|
|

<








|
>
>
|
>
>
>







1918
1919
1920
1921
1922
1923
1924
1925

1926

1927
1928

1929
1930
1931
1932

1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958






1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969

1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpObjNormalizePath --
 *
 *	Replaces each component except that last one in a pathname that is a

 *	symbolic link with the fully resolved target of that link.

 *
 * Results:

 *	Stores the resulting path in pathPtr and returns the offset of the last
 *	byte processed to obtain the resulting path.
 *
 * Side effects:

 *
 *---------------------------------------------------------------------------
 */

int
TclpObjNormalizePath(
    Tcl_Interp *interp,
    Tcl_Obj *pathPtr,		/* An unshared object containing the path to
				 * normalize. */
    int nextCheckpoint)		/* offset to start at in pathPtr.  Must either
				 * be 0 or the offset of a directory separator
				 * at the end of a path part that is already
				 * normalized.  I.e. this is not the index of
				 * the byte just after the separator.  */

{
    const char *currentPathEndPosition;
    char cur;
    const char *path = TclGetString(pathPtr);
    size_t pathLen = pathPtr->length;
    Tcl_DString ds;
    const char *nativePath;
#ifndef NO_REALPATH
    char normPath[MAXPATHLEN];
#endif







    currentPathEndPosition = path + nextCheckpoint;
    if (*currentPathEndPosition == '/') {
	currentPathEndPosition++;
    }

#ifndef NO_REALPATH
    if (nextCheckpoint == 0 && haveRealpath) {
	/*
	 * Try to get the entire path in one go
	 */


	char *lastDir = strrchr(currentPathEndPosition, '/');

	if (lastDir != NULL) {
	    nativePath = Tcl_UtfToExternalDString(NULL, path,
		    lastDir-path, &ds);
	    if (Realpath(nativePath, normPath) != NULL) {
		if (*nativePath != '/' && *normPath == '/') {
		    /*
		     * realpath transformed a relative path into an
		     * absolute path.  Fall back to the long way.
		     */

		    /*
		     * To do: This logic seems to be out of date.  This whole
		     * routine should be reviewed and cleaed up.
		     */
		} else {
		    nextCheckpoint = lastDir - path;
		    goto wholeStringOk;
		}
	    }
	    Tcl_DStringFree(&ds);
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043

2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070

2071
2072
2073
2074
2075

2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104

2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
		 * File doesn't exist.
		 */

		break;
	    }

	    /*
	     * Update the acceptable point.
	     */

	    nextCheckpoint = currentPathEndPosition - path;
	} else if (cur == 0) {
	    /*
	     * Reached end of string.
	     */

	    break;
	}
	currentPathEndPosition++;
    }

    /*
     * We should really now convert this to a canonical path. We do that with
     * 'realpath' if we have it available. Otherwise we could step through
     * every single path component, checking whether it is a symlink, but that
     * would be a lot of work, and most modern OSes have 'realpath'.
     */

#ifndef NO_REALPATH
    if (haveRealpath) {

	/*
	 * If we only had '/foo' or '/' then we never increment nextCheckpoint
	 * and we don't need or want to go through 'Realpath'. Also, on some
	 * platforms, passing an empty string to 'Realpath' will give us the
	 * normalized pwd, which is not what we want at all!
	 */

	if (nextCheckpoint == 0) {
	    return 0;
	}

	nativePath = Tcl_UtfToExternalDString(NULL, path,nextCheckpoint, &ds);
	if (Realpath(nativePath, normPath) != NULL) {
	    int newNormLen;

	wholeStringOk:
	    newNormLen = strlen(normPath);
	    if ((newNormLen == Tcl_DStringLength(&ds))
		    && (strcmp(normPath, nativePath) == 0)) {
		/*
		 * String is unchanged.
		 */

		Tcl_DStringFree(&ds);

		/*
		 * Enable this to have the native FS claim normalization of

		 * the whole path for existing files. That would permit the
		 * caller to declare normalization complete without calls to
		 * additional filesystems. Saving lots of calls is probably
		 * worth the extra access() time here. When no other FS's are
		 * registered though, things are less clear.

		 *
		if (0 == access(normPath, F_OK)) {
		    return pathLen;
		}
		 */

		return nextCheckpoint;
	    }

	    /*
	     * Free up the native path and put in its place the converted,
	     * normalized path.
	     */

	    Tcl_DStringFree(&ds);
	    Tcl_ExternalToUtfDString(NULL, normPath, (int) newNormLen, &ds);

	    if (path[nextCheckpoint] != '\0') {
		/*
		 * Not at end, append remaining path.
		 */

		int normLen = Tcl_DStringLength(&ds);

		Tcl_DStringAppend(&ds, path + nextCheckpoint,
			pathLen - nextCheckpoint);

		/*
		 * We recognise up to and including the directory separator.

		 */

		nextCheckpoint = normLen + 1;
	    } else {
		/*
		 * We recognise the whole string.
		 */

		nextCheckpoint = Tcl_DStringLength(&ds);
	    }

	    /*
	     * Overwrite with the normalized path.
	     */

	    Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&ds),
		    Tcl_DStringLength(&ds));
	}
	Tcl_DStringFree(&ds);
    }
#endif	/* !NO_REALPATH */








|





|








|
<
<
<




>
|
|
|
|
|
|

<












|





|
>
|
<
|
|
|
>










<
|







|








|
>











<
<
<
<







2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038



2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050

2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071

2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085

2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115




2116
2117
2118
2119
2120
2121
2122
		 * File doesn't exist.
		 */

		break;
	    }

	    /*
	     * Assign the end of the current component to nextCheckpoint
	     */

	    nextCheckpoint = currentPathEndPosition - path;
	} else if (cur == 0) {
	    /*
	     * The end of the string.
	     */

	    break;
	}
	currentPathEndPosition++;
    }

    /*
     * Call 'realpath' to obtain a canonical path. 



     */

#ifndef NO_REALPATH
    if (haveRealpath) {
	if (nextCheckpoint == 0) {
	    /*
	     * The path contains at most one component, e.g. '/foo' or '/', so
	     * so there is nothing to resolve. Also, on some platforms
	     * 'Realpath' transforms an empty string into the normalized pwd,
	     * which is the wrong answer. 
	     */


	    return 0;
	}

	nativePath = Tcl_UtfToExternalDString(NULL, path,nextCheckpoint, &ds);
	if (Realpath(nativePath, normPath) != NULL) {
	    int newNormLen;

	wholeStringOk:
	    newNormLen = strlen(normPath);
	    if ((newNormLen == Tcl_DStringLength(&ds))
		    && (strcmp(normPath, nativePath) == 0)) {
		/*
		 * The original path is unchanged.
		 */

		Tcl_DStringFree(&ds);

		/*
		 * Uncommenting this would mean that this native filesystem
		 * routine claims the path is normalized if the file exists,
		 * which would permit the caller to avoid iterating through

		 * other filesystems filesystems. Saving lots of calls is
		 * probably worth the extra access() time, but in the common
		 * case that no other filesystems are registered this is an
		 * unnecessary expense.
		 *
		if (0 == access(normPath, F_OK)) {
		    return pathLen;
		}
		 */

		return nextCheckpoint;
	    }

	    /*

	     * Free the original path and replace it with the normalized path.
	     */

	    Tcl_DStringFree(&ds);
	    Tcl_ExternalToUtfDString(NULL, normPath, (int) newNormLen, &ds);

	    if (path[nextCheckpoint] != '\0') {
		/*
		 * Append the remaining path components. 
		 */

		int normLen = Tcl_DStringLength(&ds);

		Tcl_DStringAppend(&ds, path + nextCheckpoint,
			pathLen - nextCheckpoint);

		/*
		 * characters up to and including the directory separator have
		 * been processed
		 */

		nextCheckpoint = normLen + 1;
	    } else {
		/*
		 * We recognise the whole string.
		 */

		nextCheckpoint = Tcl_DStringLength(&ds);
	    }





	    Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&ds),
		    Tcl_DStringLength(&ds));
	}
	Tcl_DStringFree(&ds);
    }
#endif	/* !NO_REALPATH */

2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398

2399


2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
};

/*
 *----------------------------------------------------------------------
 *
 * GetUnixFileAttributes
 *
 *	Gets the readonly attribute of a file.
 *
 * Results:
 *	Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr if there
 *	is no error. The object will have ref count 0.
 *
 * Side effects:

 *	A new object is allocated.


 *
 *----------------------------------------------------------------------
 */

static int
GetUnixFileAttributes(
    Tcl_Interp *interp,		/* The interp we are using for errors. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,		/* The name of the file (UTF-8). */
    Tcl_Obj **attributePtrPtr)	/* A pointer to return the object with. */
{
    int fileAttributes;
    WCHAR *winPath = winPathFromObj(fileName);

    fileAttributes = GetFileAttributesW(winPath);
    ckfree(winPath);








|


|
<


>
|
>
>






|

|
|







2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391

2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
};

/*
 *----------------------------------------------------------------------
 *
 * GetUnixFileAttributes
 *
 *	Gets an attribute of a file.
 *
 * Results:
 *	A standard Tcl result.

 *
 * Side effects:
 *	If there is no error assigns to *attributePtrPtr the address of a new
 *	Tcl_Obj having a refCount of zero and containing the value of the
 *	specified attribute.
 *
 *
 *----------------------------------------------------------------------
 */

static int
GetUnixFileAttributes(
    Tcl_Interp *interp,		/* The interp to report errors to. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,		/* The pathname of the file (UTF-8). */
    Tcl_Obj **attributePtrPtr)	/* Where to store the result. */
{
    int fileAttributes;
    WCHAR *winPath = winPathFromObj(fileName);

    fileAttributes = GetFileAttributesW(winPath);
    ckfree(winPath);

Changes to win/tclWinFile.c.
2538
2539
2540
2541
2542
2543
2544
2545

2546
2547
2548
2549
2550
2551
2552
2553
 *
 *---------------------------------------------------------------------------
 */

int
TclpObjNormalizePath(
    Tcl_Interp *interp,
    Tcl_Obj *pathPtr,

    int nextCheckpoint)
{
    char *lastValidPathEnd = NULL;
    Tcl_DString dsNorm;		/* This will hold the normalized string. */
    char *path, *currentPathEndPosition;
    Tcl_Obj *temp = NULL;
    int isDrive = 1;
    Tcl_DString ds;		/* Some workspace. */







|
>
|







2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
 *
 *---------------------------------------------------------------------------
 */

int
TclpObjNormalizePath(
    Tcl_Interp *interp,
    Tcl_Obj *pathPtr,	        /* An unshared object containing the path to
				 * normalize */
    int nextCheckpoint)	        /* offset to start at in pathPtr */
{
    char *lastValidPathEnd = NULL;
    Tcl_DString dsNorm;		/* This will hold the normalized string. */
    char *path, *currentPathEndPosition;
    Tcl_Obj *temp = NULL;
    int isDrive = 1;
    Tcl_DString ds;		/* Some workspace. */
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
 *
 *	Create a native representation for the given path.
 *
 * Results:
 *	The nativePath representation.
 *
 * Side effects:
 *	Memory will be allocated. The path may need to be normalized.
 *
 *---------------------------------------------------------------------------
 */

ClientData
TclNativeCreateNativeRep(
    Tcl_Obj *pathPtr)







|







3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
 *
 *	Create a native representation for the given path.
 *
 * Results:
 *	The nativePath representation.
 *
 * Side effects:
 *	Memory will be allocated. The path might be normalized.
 *
 *---------------------------------------------------------------------------
 */

ClientData
TclNativeCreateNativeRep(
    Tcl_Obj *pathPtr)